home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / src / compiler.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1996-07-21  |  559.7 KB  |  13,062 lines
  1. ; CLISP - Compiler
  2. ; Bruno Haible 20.-30.09.1988, 05.-07.10.1988, 10.10.1988, 16.12.1988
  3. ;   Version fⁿr KCL 27.06.1989, 05.-07.07.1989
  4. ;   c-VALUES erweitert am 14.07.1989
  5. ;   label-operand in assemble-LAP korrigiert am 14.07.1989
  6. ;   ANODE-Komponenten SOURCE, STACKZ eliminiert am 14.07.1989
  7. ;     (konditionell von #+COMPILER-DEBUG abhΣngig)
  8. ;   Peephole-Optimierung-Protokoll konditionell von #+PEEPHOLE-DEBUG abhΣngig
  9. ;   Version fⁿr CLISP 28.07.1989-11.08.1989
  10. ;   Variablen-Optimierungen 10.03.1991
  11. ; Michael Stoll, September-Dezember 1991:
  12. ;   - Bytecode ⁿberarbeitet
  13. ;   - Code-Optimierung bzgl. Labels/Sprⁿngen verbessert
  14. ;   - kleine Verbesserung bei c-plus/c-minus,
  15. ;     Compilation von CxxxR in Folge von (CAR) und (CDR)
  16. ;   - SUBR-Aufrufe ohne Argument-Check zur Laufzeit,
  17. ;     SUBRs als Konstanten (via #.#'name)
  18. ;   - Aufrufe lokaler Funktionen ohne Argument-Check zur Laufzeit
  19. ;   - Rekursive Aufrufe durch Unterprogrammaufruf JSR, bei Endrekursion
  20. ;     JMPTAIL (entspricht PSETQ mit anschlie▀endem Sprung)
  21. ;   - Verbesserung bei Aufruf einer Funktion mit Rest-Parametern via APPLY
  22. ; Bruno Haible, Februar-MΣrz 1992:
  23. ;   - detailliertere seclass, besseres PSETQ
  24. ;   - besseres Constant Folding
  25. ;   - Cross-Compilation
  26. ; Bruno Haible, 03.06.1992:
  27. ;   - Inline-Compilation von Aufrufen globaler Funktionen
  28. ; Bruno Haible, August 1993:
  29. ;   - Unterstⁿtzung fⁿr CLOS: generische Funktionen %GENERIC-FUNCTION-LAMBDA,
  30. ;     Optimierung unbenutzter Required-Parameter %OPTIMIZE-FUNCTION-LAMBDA
  31. ;   - GENERIC-FLET, GENERIC-LABELS
  32. ;   - Inline-Compilation von (APPLY (FUNCTION ...) ...)
  33. ; Bruno Haible, 09.06.1996:
  34. ;   - Bytecode plattform-unabhΣngig
  35. ; Weitere Vorhaben:
  36. ;   - Variablen-Environments so verΣndern, da▀ Aufruf von lokalen Funktionen
  37. ;     mittels JSR/JMPTAIL m÷glich wird (d.h. nachtrΣgliche Entscheidung, ob
  38. ;     Aufruf durch CALLC oder JSR)
  39. ;   - evtl. bessere Optimierung durch Datenflu▀analyse
  40. ;   - Inline-Compilation von Aufrufen lokaler Funktionen
  41.  
  42. ; Zur Cross-Compilation (wahlweise mit #+CLISP oder #-CLISP):
  43. ; CROSS, die Sprache und den Maschinenbezeichner in die Liste *features*
  44. ; aufnehmen, andere Maschinenbezeichner aus *features* herausnehmen.
  45. ; Dann den Compiler laden (evtl. compilieren und laden).
  46. ; Dann CROSS wieder aus der Liste *features* herausnehmen, und
  47. ; mit (cross:compile-file ...) Files compilieren.
  48.  
  49. ; #-CROSS impliziert #+CLISP.
  50.  
  51. #-CROSS (in-package "LISP")
  52. #-CROSS (export '(compiler compile compile-file disassemble))
  53. #-CROSS (pushnew 'compiler *features*)
  54.  
  55. #-CROSS (in-package "COMPILER")
  56. #+CROSS (in-package "CROSS" :nicknames '("CLISP"))
  57. #-CLISP (defmacro DEUTSCH (x ENGLISH y FRANCAIS z) y)
  58. ;; Konvention: Schreibe SYSTEM::PNAME fⁿr ein Symbol, das "zufΣllig" in
  59. ;; #<PACKAGE SYSTEM> sitzt, wir das Symbol aber nicht weiter benutzen.
  60. ;; Schreibe SYS::PNAME, wenn wir von dem Symbol irgendwelche Eigenschaften
  61. ;; voraussetzen. Schreibe COMPILER::PNAME, wenn der Compiler das Symbol
  62. ;; deklariert und es von anderen Programmteilen benutzt wird.
  63. #+CLISP (import '(sys::function-name-p sys::parse-body sys::make-load-time-eval
  64.                   sys::closure-name sys::closure-codevec sys::closure-consts
  65.                   sys::fixnump sys::short-float-p sys::single-float-p
  66.                   sys::double-float-p sys::long-float-p
  67.                   sys::search-file sys::date-format sys::line-number
  68.                   sys::%funtabref sys::inlinable
  69.                   sys::*compiling* sys::*compiling-from-file* sys::*inline-functions*
  70.                   sys::*venv* sys::*fenv* sys::*benv* sys::*genv* sys::*denv*
  71.                   sys::*toplevel-denv*
  72.                   COMPILER::C-PROCLAIM COMPILER::C-PROCLAIM-CONSTANT
  73.                   COMPILER::C-DEFUN COMPILER::C-PROVIDE COMPILER::C-REQUIRE
  74.         )        )
  75. #-CROSS (import '(sys::version sys::subr-info))
  76.  
  77. #+CROSS (shadow '(compile-file))
  78. #+CROSS (export '(compile-file))
  79.  
  80. #-CLISP (shadow '(macroexpand-1 macroexpand))
  81. #-CLISP
  82. (progn
  83.   (defun function-name-p (form)
  84.     (or (symbolp form)
  85.         (and (consp form) (eq (car form) 'SETF)
  86.              (consp (setq form (cdr form))) (null (cdr form))
  87.              (symbolp (car form))
  88.   ) )   )
  89.   (defun macroexpand-1 (form &optional (env (vector nil nil)))
  90.     (if (and (consp form) (symbolp (car form)))
  91.       (multiple-value-bind (a b c) (fenv-search (car form) (svref env 1))
  92.         (declare (ignore c))
  93.         (cond ((eq a 'system::macro) (values (funcall b form env) t))
  94.               ((macro-function (car form))
  95.                (values (funcall (macro-function (car form)) form env) t)
  96.               )
  97.               (t (values form nil))
  98.       ) )
  99.       (if (symbolp form)
  100.         (multiple-value-bind (macrop expansion)
  101.             (venv-search-macro form (svref env 0))
  102.           (if macrop
  103.             (values expansion t)
  104.             (values form nil)
  105.         ) )
  106.         (values form nil)
  107.   ) ) )
  108.   (defun macroexpand (form &optional (env (vector nil nil)))
  109.     (multiple-value-bind (a b) (macroexpand-1 form env)
  110.       (if b
  111.         (loop
  112.           (multiple-value-setq (a b) (macroexpand-1 a env))
  113.           (unless b (return (values a t)))
  114.         )
  115.         (values form nil)
  116.   ) ) )
  117.   (defun parse-body (body &optional docstring-allowed env)
  118.     (do ((bodyr body (cdr bodyr))
  119.          (declarations nil)
  120.          (docstring nil)
  121.          (form nil))
  122.         ((null bodyr) (values bodyr declarations docstring))
  123.       (cond ((and (stringp (car bodyr)) (cdr bodyr) (null docstring) docstring-allowed)
  124.              (setq docstring (car bodyr))
  125.             )
  126.             ((not (listp (setq form (macroexpand (car bodyr) env))))
  127.              (return (values bodyr declarations docstring))
  128.             )
  129.             ((eq (car form) 'DECLARE)
  130.              (dolist (decl (cdr form)) (push decl declarations))
  131.             )
  132.             (t (return (values bodyr declarations docstring)))
  133.   ) ) )
  134.   (defstruct (load-time-eval
  135.               (:print-function
  136.                 (lambda (object stream depth)
  137.                   (declare (ignore depth))
  138.                   (write-string "#." stream)
  139.                   (write (load-time-eval-form object) :stream stream)
  140.               ) )
  141.               (:constructor make-load-time-eval (form))
  142.              )
  143.     form
  144.   )
  145.   (defstruct (symbol-macro (:constructor make-symbol-macro (expansion)))
  146.     expansion
  147.   )
  148.   (defun symbol-macro-expand (v)
  149.     (and (boundp v) (symbol-macro-p (symbol-value v))
  150.          (values t (symbol-macro-expansion (symbol-value v)))
  151.   ) )
  152.   (defun fixnump (object) (typep object 'FIXNUM))
  153.   (defun short-float-p (object) (typep object 'SHORT-FLOAT))
  154.   (defun single-float-p (object) (typep object 'SINGLE-FLOAT))
  155.   (defun double-float-p (object) (typep object 'DOUBLE-FLOAT))
  156.   (defun long-float-p (object) (typep object 'LONG-FLOAT))
  157.   ; Sucht ein Programm-File. Siehe INIT.LSP :
  158.   (defun search-file (filename extensions
  159.                       &aux (use-extensions (null (pathname-type filename))) )
  160.     (when use-extensions
  161.       (setq extensions ; Case-Konversionen auf den Extensions durchfⁿhren
  162.         (mapcar #'pathname-type extensions)
  163.     ) )
  164.     ; Defaults einmergen:
  165.     (setq filename (merge-pathnames filename '#".*"))
  166.     ; Suchen:
  167.     (let ((already-searched nil))
  168.       (dolist (dir (cons '#"" '()))
  169.         (let ((search-filename
  170.                 (merge-pathnames (merge-pathnames filename dir))
  171.              ))
  172.           (unless (member search-filename already-searched :test #'equal)
  173.             (let ((xpathnames (directory search-filename :full t :circle t)))
  174.               (when use-extensions
  175.                 ; nach passenden Extensions filtern:
  176.                 (setq xpathnames
  177.                   (delete-if-not ; hat xpathname eine der gegebenen Extensions?
  178.                     #'(lambda (xpathname)
  179.                         (member (pathname-type (first xpathname)) extensions
  180.                                 :test #'string=
  181.                       ) )
  182.                     xpathnames
  183.               ) ) )
  184.               (when xpathnames
  185.                 ; nach Datum sortiert, zurⁿckgeben:
  186.                 (dolist (xpathname xpathnames)
  187.                   (setf (rest xpathname)
  188.                         (apply #'encode-universal-time (third xpathname))
  189.                 ) )
  190.                 (return (mapcar #'first (sort xpathnames #'> :key #'rest)))
  191.             ) )
  192.             (push search-filename already-searched)
  193.       ) ) )
  194.   ) )
  195.   (defun make-macro-expander (macrodef)
  196.     (let ((dummysym (make-symbol (symbol-name (car macrodef)))))
  197.       (eval `(DEFMACRO ,dummysym ,@(cdr macrodef)))
  198.       #'(lambda (form &rest env)
  199.           (apply #'lisp:macroexpand-1 (cons dummysym (cdr form)) env)
  200.         )
  201.   ) )
  202.   ; siehe DEFS1.LSP :
  203.   (defun date-format ()
  204.     (DEUTSCH "~1{~3@*~D.~4@*~D.~5@*~D ~2@*~2,'0D:~1@*~2,'0D:~0@*~2,'0D~:}"
  205.      ENGLISH "~1{~5@*~D/~4@*~D/~3@*~D ~2@*~2,'0D.~1@*~2,'0D.~0@*~2,'0D~:}"
  206.      FRANCAIS "~1{~3@*~D/~4@*~D/~5@*~D ~2@*~2,'0D:~1@*~2,'0D:~0@*~2,'0D~:}")
  207.   )
  208.   (defun sys::line-number (stream) nil)
  209. )
  210.  
  211.  
  212. ; Version des Evaluators:
  213. #+CROSS
  214. (defconstant *big-endian*
  215.   ;; When cross-compiling within CLISP, we generate compiled closures
  216.   ;; in memory with CLISP's endianness. They will be written out to file
  217.   ;; as little-endian.
  218.   #+CLISP system::*big-endian*
  219.   ;; When cross-compiling outside CLISP, we have no endianness reversion code
  220.   ;; in the #Y printer. So let's generate little-endian compiled closures.
  221.   #-CLISP nil
  222. )
  223. #+CROSS
  224. (defun version ()
  225.   (list '19071996)
  226. )
  227.  
  228. (defconstant *keyword-package* (find-package "KEYWORD"))
  229. (defconstant *lisp-package* (find-package "LISP"))
  230.  
  231. ; Variablen fⁿr Top-Level-Aufruf:
  232. (defvar *compiling* nil) ; gibt an, ob gerade beim Compilieren
  233. ; (defvar *error-count*) ; Anzahl der aufgetretenen Errors
  234. ; (defvar *warning-count*) ; Anzahl der aufgetretenen Warnungen
  235. (defvar *compile-warnings* t) ; ob Compiler-Warnungen ausgegeben werden
  236. (defvar *compile-verbose* t) ; ob Compiler-Kommentare ausgegeben werden
  237. (defvar *compile-print* nil) ; ob der Compiler ausgibt, wo er gerade ist
  238. (defvar *compiling-from-file*) ; NIL oder T wenn von COMPILE-FILE aufgerufen
  239. (defvar *compile-file-pathname* nil) ; CLtL2 S. 680
  240. (defvar *compile-file-truename* nil) ; CLtL2 S. 680
  241. (defvar *compile-file-lineno1* nil)
  242. (defvar *compile-file-lineno2* nil)
  243. (defvar *c-listing-output*) ; Compiler-Listing-Stream oder nil
  244. (defvar *c-error-output*) ; Compiler-Error-Stream
  245. ; Es ist im wesentlichen
  246. ; *c-error-output* = (make-broadcast-stream *error-output* *c-listing-output*)
  247. (defvar *known-special-vars*) ; Namen von deklarierten dynamischen Variablen
  248. (defvar *constant-special-vars*) ; Namen und Werte von konstanten Variablen
  249.  
  250. ; Variablen fⁿr COMPILE-FILE:
  251. (defvar *fasoutput-stream* nil) ; Compiler-Output-Stream oder nil
  252. (defvar *liboutput-stream* nil) ; Compiler-Library-Stream oder nil
  253. (defvar *coutput-file* nil) ; Compiler-C-Output-File oder nil
  254. (defvar *coutput-stream* nil) ; Compiler-C-Output-Stream oder nil
  255. (defvar *functions-with-errors* nil) ; Namen der Funktionen, wo es Fehler gab
  256. (defvar *known-functions*) ; Namen der bisher bekannten Funktionen,
  257.                            ; wird vom Macroexpander von DEFUN verΣndert
  258. (defvar *unknown-functions*) ; Namen der bisher unbekannten Funktionen
  259. (defvar *unknown-free-vars*) ; Namen von undeklarierten dynamischen Variablen
  260. (defvar *inline-functions*) ; global inline-deklarierte Funktionssymbole
  261. (defvar *notinline-functions*) ; global notinline-deklarierte Funktionssymbole
  262. (defvar *inline-definitions*) ; Aliste globaler inlinebarer Funktionsdefinitionen
  263. (defvar *user-declaration-types*) ; global definierte zusΣtzliche Deklarationen
  264. (defvar *compiled-modules*) ; bereits "geladene" (compilierte) Modulnamen
  265. (defvar *package-tasks*) ; noch durchzufⁿhrende Package-Anforderungen
  266. (defvar *ffi-module* nil) ; Daten, die das FFI ansammelt
  267.  
  268. #|
  269. Basis fⁿr den Zielcode ist eine Stackmaschine mit zwei Stacks:
  270. STACK (Stack fⁿr LISP-Objekte und Frames) und SP (Stack fⁿr sonstiges).
  271. Mehrfache Werte werden kurzfristig in A0/A1/A2/MV_SPACE (D7.W Werte, bei D7.W=0
  272. ist A0=NIL) gehalten, lΣngerfristig auf dem STACK abgelegt.
  273.  
  274. 1. Pass des Compilers:
  275. Macro-Expansion, Codegenerierung (symbolisch), Allokation von Variablen auf
  276. dem STACK oder in Closures, Optimierung auf LISP-Ebene.
  277. Danach steht fⁿr jede beteiligte Funktion das Stack-Layout fest.
  278. Die Information steckt in einem Netz von ANODEs.
  279. 2. Pass des Compilers:
  280. Aufl÷sung der Variablenbezⁿge, Optimierung auf Code-Ebene
  281. (Peephole-Optimierung), Kreation compilierter funktionaler Objekte.
  282. 3. Pass des Compilers:
  283. Aufl÷sung von Bezⁿgen zwischen den einzelnen funktionalen Objekten.
  284.  
  285. Zielsprache:
  286. ============
  287.  
  288. ein Bytecode-Interpreter.
  289.  
  290. Ein compiliertes funktionales Objekt (Closure) hat folgenden Aufbau:
  291. FUNC = #Closure( Name
  292.                  CODEVEC
  293.                  [VenvConst] {BlockConst}* {TagbodyConst}*
  294.                  {Keyword}* {sonstige Const}*
  295.                )
  296.  
  297. VenvConst, BlockConst, TagbodyConst : diese LISP-Objekte werden innerhalb der
  298. Funktion als Konstanten betrachtet. Sie werden beim Aufbau der Funktion zur
  299. Laufzeit mitgegeben. Sollten diese drei Teile fehlen (d.h. diese Funktion ist
  300. von der Inkarnation unabhΣngig, weil sie auf keine lexikalischen Variablen,
  301. Blocks oder Tags zugreift, die im compilierten Code au▀erhalb von ihr definiert
  302. werden), so hei▀t die Funktion autonom.
  303.  
  304. Keyword : die Keywords in der richtigen Reihenfolge. Werden vom Interpreter bei
  305. der Parameterⁿbergabe gebraucht.
  306.  
  307. sonstige Const: sonstige Konstanten, auf die vom Innern der Funktion aus Bezug
  308. genommen wird. Sie sind untereinander und zu allen Keywords paarweise nicht EQL.
  309.  
  310. CODEVEC = Code-Vektor, ein SIMPLE-BIT-VECTOR,
  311.                  2 Bytes : maximale SP-Tiefe, 1-Anteil
  312.                  2 Bytes : maximale SP-Tiefe, jmpbufsize-Anteil
  313.                  2 Bytes : Anzahl der required parameter
  314.                  2 Bytes : Anzahl der optionalen Parameter
  315.                  1 Byte : Flags. Bit 0: ob &REST - Parameter angegeben
  316.                                  Bit 7: ob Keyword-Parameter angegeben
  317.                                  Bit 6: &ALLOW-OTHER-KEYS-Flag
  318.                                  Bit 4: ob generische Funktion
  319.                  1 Byte : Kⁿrzel fⁿr den Argumenttyp, fⁿr schnelleres FUNCALL
  320.                  Falls Keyword-Parameter angegeben:
  321.                    4 Bytes : 2 Bytes : Anzahl der Keyword-Parameter
  322.                              2 Bytes : Offset in FUNC der Keywords
  323.                  dann
  324.                  eine Folge von Byte-Instruktionen.
  325.  
  326. |#
  327. ; externe ReprΣsentation einer Closure:
  328. ; #Y(name
  329. ;    #LΣngeY(Byte in Hex ... Byte in Hex)
  330. ;    weitere Konstanten
  331. ;   )
  332.  
  333. #-CLISP
  334. (progn
  335.   (defstruct (closure (:print-function print-closure))
  336.     name    ; der Name der Closure
  337.     codevec ; Liste der Bytes des Codevektor
  338.     consts  ; Liste der Konstanten
  339.   )
  340.   (defun print-closure (closure stream depth)
  341.     (declare (ignore depth))
  342.     (write-string "#Y(" stream)
  343.     (write (closure-name closure) :stream stream)
  344.     (write-char #\space stream)
  345.     (write-char #\# stream)
  346.     (write (length (closure-codevec closure)) :stream stream :base 10. :radix nil :readably nil)
  347.     (write-char #\Y stream)
  348.     ;(write (closure-codevec closure) :stream stream :base 16.) ; stattdessen:
  349.     (write-char #\( stream)
  350.     (do ((i 0 (1- i))
  351.          (L (closure-codevec closure) (cdr L)))
  352.         ((endp L))
  353.       (when (zerop i) (write-char #\newline stream) (setq i 25))
  354.       (write-char #\space stream)
  355.       (write (car L) :stream stream :base 16. :radix nil :readably nil)
  356.     )
  357.     (write-char #\) stream)
  358.     (write-char #\newline stream)
  359.     (dolist (x (closure-consts closure))
  360.       (write-char #\space stream)
  361.       (write x :stream stream)
  362.     )
  363.     (write-char #\) stream)
  364.   )
  365. )
  366.  
  367. #+CLISP
  368. (progn
  369.   (defsetf sys::%record-ref sys::%record-store)
  370.   (defsetf closure-name (closure) (new-name)
  371.     `(sys::%record-store ,closure 0 ,new-name)
  372.   )
  373.   (defun make-closure (&key name codevec consts)
  374.     (sys::%make-closure name (sys::make-code-vector codevec) consts)
  375.   )
  376. )
  377.  
  378. #-CLISP
  379. (set-dispatch-macro-character #\# #\Y
  380.   #'(lambda (stream subchar arg)
  381.       (declare (ignore subchar))
  382.       (if arg
  383.         ; Codevector lesen
  384.         (let ((obj (let ((*read-base* 16.)) (read stream t nil t))))
  385.           (unless (= (length obj) arg)
  386.             (error (DEUTSCH "Falsche LΣnge eines Closure-Vektors: ~S"
  387.                     ENGLISH "Bad length of closure vector: ~S"
  388.                     FRANCAIS "Mauvaise longueur pour un vecteur de fermeture : ~S")
  389.                    arg
  390.           ) )
  391.           obj
  392.         )
  393.         ; Closure lesen
  394.         (let ((obj (read stream t nil t)))
  395.           (make-closure :name (first obj) :codevec (second obj) :consts (cddr obj))
  396.     ) ) )
  397. )
  398.  
  399. #|
  400. Instruktionen:
  401. Instruktionen k÷nnen Operanden haben.
  402. Operanden, die Sprungziele (labels) darstellen, sind (um CodelΣnge zu sparen)
  403. relativ angegeben:
  404.     PC := PC(in der Instruktion) + Operand(signed)
  405. Operanden, die Zahlen darstellen, sind Integers >=0.
  406. Format der Operanden:
  407. bei LOAD, ... mit kleinem Operanden: implizit im Code.
  408. bei allen anderen Instruktionen:
  409.   nΣchstes Byte:
  410.     Bit 7 = 0 --> Bits 6..0 sind der Operand (7 Bits).
  411.     Bit 7 = 1 --> Bits 6..0 und nΣchstes Byte bilden den Operanden (15 Bits).
  412.                   Bei Sprungdistanzen: Sollte dieser =0 sein, so bilden
  413.                   die nΣchsten 4 Bytes den Operanden (32 Bits).
  414.  
  415.  
  416. (1) Instruktionen fⁿr Konstanten:
  417.  
  418. Mnemonic                      Bedeutung
  419.  
  420. (NIL)                         A0 := NIL, 1 Wert
  421.  
  422. (PUSH-NIL n)                  n-mal: -(STACK) := NIL, undefinierte Werte
  423.  
  424. (T)                           A0 := T, 1 Wert
  425.  
  426. (CONST n)                     A0 := Konstante Nr. n aus FUNC, 1 Wert
  427.  
  428.  
  429. (2) Instruktionen fⁿr statische Variablen
  430.  
  431. Mnemonic                      Bedeutung
  432.  
  433. (LOAD n)                      A0 := (STACK+4*n), 1 Wert
  434.  
  435. (LOADI k1 k2 n)               A0 := ((SP+4*k)+4*n), 1 Wert
  436.  
  437. (LOADC n m)                   A0 := (svref (STACK+4*n) 1+m), 1 Wert
  438.  
  439. (LOADV k m)                   A0 := (svref ... m)
  440.                                     (svref ... 0) ; k mal wiederholt
  441.                                     VenvConst,
  442.                               1 Wert
  443.  
  444. (LOADIC k1 k2 n m)            A0 := (svref ((SP+4*k)+4*n) 1+m), 1 Wert
  445.  
  446. (STORE n)                     (STACK+4*n) := A0, 1 Wert
  447.  
  448. (STOREI k1 k2 n)              ((SP+4*k)+4*n) := A0, 1 Wert
  449.  
  450. (STOREC n m)                  (svref (STACK+4*n) 1+m) := A0, 1 Wert
  451.  
  452. (STOREV k m)                  (svref ... m)
  453.                               (svref ... 0) ; k mal wiederholt
  454.                               VenvConst
  455.                               := A0, 1 Wert
  456.  
  457. (STOREIC k1 k2 n m)           (svref ((SP+4*k)+4*n) 1+m) := A0, 1 Wert
  458.  
  459.  
  460. (3) Instruktionen fⁿr dynamische Variablen
  461.  
  462. Mnemonic                      Bedeutung
  463.  
  464. (GETVALUE n)                  A0 := (symbol-value (CONST n)), 1 Wert
  465.  
  466. (SETVALUE n)                  (setf (symbol-value (CONST n)) A0), 1 Wert
  467.  
  468. (BIND n)                      bindet (CONST n), ein Symbol, dynamisch an A0.
  469.                               Undefinierte Werte.
  470.  
  471. (UNBIND1)                     l÷st einen Bindungsframe auf
  472. (UNBIND n)                    l÷st n Bindungsframes auf
  473.  
  474. (PROGV)                       bindet dynamisch die Symbole in der Liste
  475.                               (STACK)+ an die Werte in der Liste A0 und baut
  476.                               dabei genau einen Bindungsframe auf,
  477.                               undefinierte Werte
  478.  
  479.  
  480. (4) Instruktionen fⁿr Stackoperationen
  481.  
  482. Mnemonic                      Bedeutung
  483.  
  484. (PUSH)                        -(STACK) := A0, undefinierte Werte
  485.  
  486. (POP)                         A0 := (STACK)+, 1 Wert
  487.  
  488. (SKIP n)                      STACK := STACK+4*n
  489.  
  490. (SKIPI k1 k2 n)               STACK := (SP+4*k)+4*n, SP:=SP+4*(k+1)
  491.  
  492. (SKIPSP k1 k2)                SP := SP+4*k
  493.  
  494.  
  495. (5) Instruktionen fⁿr Programmflu▀ und Sprⁿnge
  496.  
  497. Mnemonic                      Bedeutung
  498.  
  499. (SKIP&RET n)                  STACK := STACK+4*n, beendet die Funktion
  500.                               mit den Werten A0/...
  501.  
  502. (JMP label)                   Sprung zu label
  503.  
  504. (JMPIF label)                 falls A0 /= NIL : Sprung zu label.
  505.  
  506. (JMPIFNOT label)              falls A0 = NIL : Sprung zu label.
  507.  
  508. (JMPIF1 label)                falls A0 /= NIL : 1 Wert, Sprung zu label.
  509.  
  510. (JMPIFNOT1 label)             falls A0 = NIL : 1 Wert, Sprung zu label.
  511.  
  512. (JMPIFATOM label)             falls A0 kein Cons : Sprung zu label.
  513.                               Undefinierte Werte.
  514.  
  515. (JMPIFCONSP label)            falls A0 ein Cons : Sprung zu label.
  516.                               Undefinierte Werte.
  517.  
  518. (JMPIFEQ label)               falls A0 EQ zu (STACK)+ : Sprung zu label.
  519.                               Undefinierte Werte.
  520.  
  521. (JMPIFNOTEQ label)            falls A0 nicht EQ zu (STACK)+ : Sprung zu label.
  522.                               Undefinierte Werte.
  523.  
  524. (JMPIFEQTO n label)           falls (STACK)+ EQ zu (CONST n) : Sprung zu label.
  525.                               Undefinierte Werte.
  526.  
  527. (JMPIFNOTEQTO n label)        falls (STACK)+ nicht EQ zu (CONST n) : Sprung zu label.
  528.                               Undefinierte Werte.
  529.  
  530. (JMPHASH n label)             Sucht A0 in der EQ- oder EQL-Hash-Tabelle
  531.                               (CONST n). Gefunden: Sprung ans von GETHASH
  532.                               gelieferte Label. Nicht gefunden: Sprung zu
  533.                               label. Undefinierte Werte.
  534.  
  535. (JMPHASHV n label)            Sucht A0 in der EQ- oder EQL-Hash-Tabelle
  536.                               (svref (CONST 0) n). Gefunden: Sprung ans von
  537.                               GETHASH gelieferte Label. Nicht gefunden: Sprung
  538.                               zu label. Undefinierte Werte.
  539.  
  540. (JSR label)                   Unterprogrammaufruf: lege Closure auf den STACK und
  541.                               springe zu label (mit undefinierten Werten),
  542.                               (RET) setzt das Programm an der Stelle nach
  543.                               dem (JSR label) fort.
  544.  
  545. (JMPTAIL m n label)           Wiederverwendung eines Stack-Frames: n>=m.
  546.                               Der Stack-Frame der Gr÷▀e n wird auf Gr÷▀e m
  547.                               verkleinert, indem die unteren m EintrΣge um
  548.                               n-m nach oben kopiert werden:
  549.                               (STACK+4*(n-m)...STACK+4*(n-1)) := (STACK+4*0...STACK+4*(m-1)),
  550.                               STACK := STACK + 4*(n-m),
  551.                               dann -(STACK) := Closure,
  552.                               Sprung zu label mit undefinierten Werten.
  553.  
  554.  
  555. (6) Instruktionen fⁿr Environments und Closures
  556.  
  557. Mnemonic                      Bedeutung
  558.  
  559. (VENV)                        A0 := VenvConst aus FUNC, 1 Wert
  560.  
  561. (MAKE-VECTOR1&PUSH n)         kreiert einen simple-vector mit n+1 (n>=0) Kom-
  562.                               ponenten und steckt A0 als Komponente 0 hinein.
  563.                               -(STACK) := der neue Vektor. Undefinierte Werte.
  564.  
  565. (COPY-CLOSURE m n)            kopiert die Closure (CONST m) aus FUNC und
  566.                               ersetzt in der Kopie fⁿr i=0,...,n-1 (n>0) die
  567.                               Komponente (CONST i) durch (STACK+4*(n-1-i)).
  568.                               STACK := STACK+4*n.
  569.                               A0 := Closure-Kopie, 1 Wert
  570.  
  571.  
  572. (7) Instruktionen fⁿr Funktionsaufrufe
  573.  
  574. Mnemonic                      Bedeutung
  575.  
  576. (CALL k n)                    ruft die Funktion (CONST n) mit k Argumenten
  577.                               (STACK+4*(k-1)),...,(STACK+4*0) auf,
  578.                               STACK:=STACK+4*k,
  579.                               Ergebnis kommt nach A0/...
  580.  
  581. (CALL0 n)                     ruft die Funktion (CONST n) mit 0 Argumenten
  582.                               auf, Ergebnis kommt nach A0/...
  583.  
  584. (CALL1 n)                     ruft die Funktion (CONST n) mit einem Argument
  585.                               (STACK)+ auf, Ergebnis kommt nach A0/...
  586.  
  587. (CALL2 n)                     ruft die Funktion (CONST n) mit zwei Argumenten
  588.                               4(STACK),(STACK) auf, STACK:=STACK+8,
  589.                               Ergebnis kommt nach A0/...
  590.  
  591. (CALLS1 n)                    ruft die Funktion (FUNTAB n)
  592. (CALLS2 n)                    bzw. (FUNTAB 256+n)
  593.                               (ein SUBR ohne Rest-Parameter) auf,
  594.                               mit der korrekten Argumentezahl auf dem STACK.
  595.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  596.  
  597. (CALLSR m n)                  ruft die Funktion (FUNTABR n)
  598.                               (ein SUBR mit Rest-Parameter) auf,
  599.                               mit der korrekten Argumentezahl und zusΣtzlich
  600.                               m restlichen Argumenten auf dem STACK.
  601.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  602.  
  603. (CALLC)                       ruft die Funktion A0 (eine compilierte Closure
  604.                               ohne Keyword-Parameter) auf. Argumente
  605.                               sind schon im richtigen Format auf dem STACK,
  606.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  607.  
  608. (CALLCKEY)                    ruft die Funktion A0 (eine compilierte Closure
  609.                               mit Keyword-Parameter) auf. Argumente
  610.                               sind schon im richtigen Format auf dem STACK,
  611.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  612.  
  613. (FUNCALL n)                   ruft die Funktion (STACK+4*n) mit n (n>=0)
  614.                               Argumenten (alle auf dem Stack) auf,
  615.                               STACK:=STACK+4*(n+1)
  616.                               Ergebnis kommt nach A0/...
  617.  
  618. (APPLY n)                     ruft die Funktion (STACK+4*n) mit n (n>=0)
  619.                               Argumenten (alle auf dem Stack) und weiteren
  620.                               Argumenten (Liste in A0) auf,
  621.                               STACK:=STACK+4*(n+1),
  622.                               Ergebnis kommt nach A0/...
  623.  
  624.  
  625. (8) Instruktionen fⁿr optionale und Keyword-Argumente
  626.  
  627. Mnemonic                      Bedeutung
  628.  
  629. (PUSH-UNBOUND n)              n-mal: -(STACK) := #<UNBOUND>, undefinierte Werte
  630.  
  631. (UNLIST n m)                  Liste A0 n mal verkⁿrzen: -(STACK) := (car A0),
  632.                               A0 := (cdr A0). Bei den letzten m Mal darf A0
  633.                               schon zu Ende sein, dann -(STACK) := #<UNBOUND>
  634.                               stattdessen. Am Schlu▀ mu▀ A0 = NIL sein,
  635.                               undefinierte Werte. 0 <= m <= n.
  636.  
  637. (UNLIST* n m)                 Liste A0 n mal verkⁿrzen: -(STACK) := (car A0),
  638.                               A0 := (cdr A0). Bei den letzten m Mal darf A0
  639.                               schon zu Ende sein, dann -(STACK) := #<UNBOUND>.
  640.                               stattdessen. Dann -(STACK) := (nthcdr n A0),
  641.                               undefinierte Werte. 0 <= m <= n, n > 0.
  642.  
  643. (JMPIFBOUNDP n label)         falls (STACK+4*n) /= #<UNBOUND> :
  644.                                 Sprung zu label, A0 := (STACK+4*n), 1 Wert.
  645.                               Sonst undefinierte Werte.
  646.  
  647. (BOUNDP n)                    A0 := (NIL falls (STACK+4*n)=#<UNBOUND>, T sonst), 1 Wert
  648.  
  649. (UNBOUND->NIL n)              Falls (STACK+4*n) = #<UNBOUND>: (STACK+4*n) := NIL
  650.  
  651.  
  652. (9) Instruktionen zur Behandlung mehrerer Werte
  653.  
  654. Mnemonic                      Bedeutung
  655.  
  656. (VALUES0)                     A0 := NIL, 0 Werte
  657.  
  658. (VALUES1)                     A0 := A0, 1 Wert
  659.  
  660. (STACK-TO-MV n)               holt n Werte von (STACK)+ herab,
  661.                               STACK:=STACK+4*n
  662.  
  663. (MV-TO-STACK)                 Multiple Values A0/A1/... auf -(STACK), 1. Wert
  664.                               zuoberst, STACK:=STACK-4*D7.W,
  665.                               danach undefinierte Werte
  666.  
  667. (NV-TO-STACK n)               die ersten n Werte (n>=0) auf -(STACK), 1. Wert
  668.                               zuoberst, STACK:=STACK-4*n, undefinierte Werte
  669.  
  670. (MV-TO-LIST)                  Multiple Values A0/... als Liste nach A0, 1 Wert
  671.  
  672. (LIST-TO-MV)                  A0/... := (values-list A0)
  673.  
  674. (MVCALLP)                     rette STACK auf -(SP), rette A0 auf -(STACK)
  675.  
  676. (MVCALL)                      fⁿhre einen Funktionsaufruf aus, wobei zwischen
  677.                               STACK und STACK:=(SP)+ die Funktion (ganz oben)
  678.                               und die Argumente stehen,
  679.                               Ergebnis kommt nach A0/...
  680.  
  681.  
  682. (10) Instruktionen fⁿr BLOCK
  683.  
  684. Mnemonic                      Bedeutung
  685.  
  686. (BLOCK-OPEN n label)          Legt einen Block-Cons (mit CAR=(CONST n) und
  687.                               CDR=Framepointer) auf -(STACK) ab, baut einen
  688.                               Block-Frame auf. Bei einem RETURN auf diesen
  689.                               Frame wird zu label gesprungen.
  690.  
  691. (BLOCK-CLOSE)                 Verlasse den Block und baue dabei einen Block-
  692.                               Frame ab (inklusive der Block-Cons-Variablen)
  693.  
  694. (RETURN-FROM n)               Verlasse den Block, dessen Block-Cons
  695.                               (CONST n) ist, mit den Werten A0/...
  696.  
  697. (RETURN-FROM-I k1 k2 n)       Verlasse den Block, dessen Block-Cons
  698.                               ((SP+4*k)+4*n) ist, mit den Werten A0/...
  699.  
  700.  
  701. (11) Instruktionen fⁿr TAGBODY
  702.  
  703. Mnemonic                      Bedeutung
  704.  
  705. (TAGBODY-OPEN n label1 ... labelm)
  706.                               Legt einen Tagbody-Cons (mit CAR = (CONST n),
  707.                               einem Simple-Vector der LΣnge m, und
  708.                               CDR=Framepointer) auf -(STACK) ab, baut einen
  709.                               Tagbody-Frame auf. Bei einem GO mit Nummer l
  710.                               wird zu labell gesprungen. Undefinierte Werte.
  711.  
  712. (TAGBODY-CLOSE-NIL)           Verlasse den Tagbody und baue dabei einen
  713.                               Tagbody-Frame ab (inklusive der Tagbody-Cons-
  714.                               Variablen).
  715.                               A0 := NIL, 1 Wert
  716.  
  717. (TAGBODY-CLOSE)               Verlasse den Tagbody und baue dabei
  718.                               einen Tagbody-Frame ab (inklusive der
  719.                               Tagbody-Cons-Variablen).
  720.  
  721. (GO n l)                      Springe im Tagbody, dessen Tagbody-Cons
  722.                               (CONST n) ist, an Tag Nummer l
  723.  
  724. (GO-I k1 k2 n l)              Springe im Tagbody, dessen Tagbody-Cons
  725.                               ((SP+4*k)+4*n) ist, an Tag Nummer l
  726.  
  727.  
  728. (12) Instruktionen fⁿr CATCH und THROW
  729.  
  730. Mnemonic                      Bedeutung
  731.  
  732. (CATCH-OPEN label)            baut einen CATCH-Frame auf mit A0 als Tag;
  733.                               bei einem THROW auf dieses Tag wird zu label
  734.                               gesprungen
  735.  
  736. (CATCH-CLOSE)                 l÷st einen CATCH-Frame auf
  737.  
  738. (THROW)                       fⁿhrt ein THROW auf den Catch-Tag (STACK)+ aus,
  739.                               mit den Werten A0/...
  740.  
  741.  
  742. (13) Instruktionen fⁿr UNWIND-PROTECT
  743.  
  744. Mnemonic                      Bedeutung
  745.  
  746. (UNWIND-PROTECT-OPEN label)   baut einen UNWIND-PROTECT-Frame auf;
  747.                               bei einem Unwind wird unter Rettung
  748.                               der Werte zu label gesprungen
  749.  
  750. (UNWIND-PROTECT-NORMAL-EXIT)  l÷st einen Unwind-Protect-Frame auf, schreibt
  751.                               eine Weitermach-Adresse auf SP, rettet die
  752.                               Werte und fΣngt an, den folgenden Cleanup-Code
  753.                               auszufⁿhren
  754.  
  755. (UNWIND-PROTECT-CLOSE)        beendet den Cleanup-Code: schreibt die
  756.                               geretteten Werte zurⁿck, fⁿhrt ein RTS aus
  757.  
  758. (UNWIND-PROTECT-CLEANUP)      l÷st einen Unwind-Protect-Frame auf,
  759.                               schreibt eine Weitermach-Adresse und
  760.                               den PC auf SP, rettet die Werte und
  761.                               fΣngt an, den Cleanup-Code auszufⁿhren
  762.  
  763.  
  764. (14) Instruktionen fⁿr HANDLER-BIND
  765.  
  766. Mnemonic                      Bedeutung
  767.  
  768. (HANDLER-OPEN n)              baut einen HANDLER-Frame auf; (CONST n) enthΣlt
  769.                               die Condition-Typen, die entsprechenden Labels
  770.                               und die aktuelle SP-Tiefe
  771.  
  772. (HANDLER-BEGIN&PUSH)          beginnt einen Handler: stellt den SP-Zustand
  773.                               wie beim HANDLER-OPEN her,
  774.                               A0 := dem Handler ⁿbergebene Condition, 1 Wert,
  775.                               -(STACK) := A0
  776.  
  777.  
  778. (15) Kurz-Instruktionen fⁿr einige Funktionen
  779.  
  780. Mnemonic                      Bedeutung
  781.  
  782. (NOT)                         A0 := (not A0), 1 Wert
  783.  
  784. (EQ)                          A0 := (eq (STACK)+ A0), 1 Wert
  785.  
  786. (CAR)                         A0 := (car A0), 1 Wert
  787.  
  788. (CDR)                         A0 := (cdr A0), 1 Wert
  789.  
  790. (CONS)                        A0 := (cons (STACK)+ A0), 1 Wert
  791.  
  792. (SYMBOL-FUNCTION)             A0 := (symbol-function A0), 1 Wert
  793.  
  794. (SVREF)                       A0 := (svref (STACK)+ A0), 1 Wert
  795.  
  796. (SVSET)                       (setf (svref (STACK) A0) (STACK+4)),
  797.                               A0 := (STACK+4), 1 Wert, STACK:=STACK+8
  798.  
  799. (LIST n)                      Bildet eine Liste aus den untersten n auf dem STACK
  800.                               liegenden Objekten, STACK := STACK + 4*n,
  801.                               Liste nach A0, 1 Wert
  802.  
  803. (LIST* n)                     Bildet eine Liste aus den untersten n auf dem STACK
  804.                               liegenden Objekten und A0, STACK := STACK + 4*n,
  805.                               Liste nach A0, 1 Wert
  806.  
  807.  
  808. (16)
  809. ZusΣtzlich gibt es kombinierte Operationen im Format
  810. (<OP1>&<OP2>&...&<OPn> <Operanden_1> <Operanden_2> ... <Operanden_n>) .
  811.  
  812. Mnemonic                           Bedeutung
  813.  
  814. (NIL&PUSH)                         (NIL) (PUSH)
  815. (T&PUSH)                           (T) (PUSH)
  816. (CONST&PUSH n)                     (CONST n) (PUSH)
  817. (LOAD&PUSH n)                      (LOAD n) (PUSH)
  818. (LOADI&PUSH k1 k2 n)               (LOADI k1 k2 n) (PUSH)
  819. (LOADC&PUSH n m)                   (LOADC n m) (PUSH)
  820. (LOADV&PUSH k m)                   (LOADV k m) (PUSH)
  821. (POP&STORE n)                      (POP) (STORE n)
  822. (GETVALUE&PUSH n)                  (GETVALUE n) (PUSH)
  823. (JSR&PUSH label)                   (JSR label) (PUSH)
  824. (COPY-CLOSURE&PUSH m n)            (COPY-CLOSURE m n) (PUSH)
  825. (CALL&PUSH k n)                    (CALL k n) (PUSH)
  826. (CALL1&PUSH n)                     (CALL1 n) (PUSH)
  827. (CALL2&PUSH n)                     (CALL2 n) (PUSH)
  828. (CALLS1&PUSH n)                    (CALLS1 n) (PUSH)
  829. (CALLS2&PUSH n)                    (CALLS2 n) (PUSH)
  830. (CALLSR&PUSH m n)                  (CALLSR m n) (PUSH)
  831. (CALLC&PUSH)                       (CALLC) (PUSH)
  832. (CALLCKEY&PUSH)                    (CALLCKEY) (PUSH)
  833. (FUNCALL&PUSH n)                   (FUNCALL n) (PUSH)
  834. (APPLY&PUSH n)                     (APPLY n) (PUSH)
  835. (CAR&PUSH)                         (CAR) (PUSH)
  836. (CDR&PUSH)                         (CDR) (PUSH)
  837. (CONS&PUSH)                        (CONS) (PUSH)
  838. (LIST&PUSH n)                      (LIST n) (PUSH)
  839. (LIST*&PUSH n)                     (LIST* n) (PUSH)
  840. (NIL&STORE n)                      (NIL) (STORE n)
  841. (T&STORE n)                        (T) (STORE n)
  842. (LOAD&STOREC k n m)                (LOAD k) (STOREC n m)
  843. (CALLS1&STORE n k)                 (CALLS1 n) (STORE k)
  844. (CALLS2&STORE n k)                 (CALLS2 n) (STORE k)
  845. (CALLSR&STORE m n k)               (CALLSR m n) (STORE k)
  846. (LOAD&CDR&STORE n)                 (LOAD n) (CDR) (STORE n)
  847. (LOAD&CONS&STORE n)                (LOAD n+1) (CONS) (STORE n)
  848. (LOAD&INC&STORE n)                 (LOAD n) (CALL1 #'1+) (STORE n)
  849. (LOAD&DEC&STORE n)                 (LOAD n) (CALL1 #'1-) (STORE n)
  850. (LOAD&CAR&STORE m n)               (LOAD m) (CAR) (STORE n)
  851. (CALL1&JMPIF n label)              (CALL1 n) (JMPIF label)
  852. (CALL1&JMPIFNOT n label)           (CALL1 n) (JMPIFNOT label)
  853. (CALL2&JMPIF n label)              (CALL2 n) (JMPIF label)
  854. (CALL2&JMPIFNOT n label)           (CALL2 n) (JMPIFNOT label)
  855. (CALLS1&JMPIF n label)             (CALLS1 n) (JMPIF label)
  856. (CALLS1&JMPIFNOT n label)          (CALLS1 n) (JMPIFNOT label)
  857. (CALLS2&JMPIF n label)             (CALLS2 n) (JMPIF label)
  858. (CALLS2&JMPIFNOT n label)          (CALLS2 n) (JMPIFNOT label)
  859. (CALLSR&JMPIF m n label)           (CALLSR m n) (JMPIF label)
  860. (CALLSR&JMPIFNOT m n label)        (CALLSR m n) (JMPIFNOT label)
  861. (LOAD&JMPIF n label)               (LOAD n) (JMPIF label)
  862. (LOAD&JMPIFNOT n label)            (LOAD n) (JMPIFNOT label)
  863. (LOAD&CAR&PUSH n)                  (LOAD n) (CAR) (PUSH)
  864. (LOAD&CDR&PUSH n)                  (LOAD n) (CDR) (PUSH)
  865. (LOAD&INC&PUSH n)                  (LOAD n) (CALL1 #'1+) (PUSH)
  866. (LOAD&DEC&PUSH n)                  (LOAD n) (CALL1 #'1-) (PUSH)
  867. (CONST&SYMBOL-FUNCTION n)          (CONST n) (SYMBOL-FUNCTION)
  868. (CONST&SYMBOL-FUNCTION&PUSH n)     (CONST n) (SYMBOL-FUNCTION) (PUSH)
  869. (CONST&SYMBOL-FUNCTION&STORE n k)  (CONST n) (SYMBOL-FUNCTION) (STORE k)
  870.  
  871.  
  872. |#
  873.  
  874. ; Instruktionen-Klassifikation:
  875. ; O = Instruktion ohne Operand
  876. ; K = numerischer Operand oder
  877. ;     Kurz-Operand (dann ist das Byte = short-code-ops[x] + Operand)
  878. ; N = numerischer Operand
  879. ; B = Byte-Operand
  880. ; L = Label-Operand
  881. ; NH = numerischer Operand, der eine Hashtable referenziert
  882. ; NC = numerischer Operand, der ein Handler-Cons referenziert
  883. ; LX = so viele Label-Operanden, wie der vorangehende Operand angibt
  884.  
  885. ; Die Position in der Instruction-Table liefert den eigentlichen Code der
  886. ; Instruktion (>= 0, < short-code-base), Codes >= short-code-base werden
  887. ; von den K-Instruktionen belegt.
  888. (defconstant instruction-table
  889.   '#(; (1) Konstanten
  890.      (NIL O) (PUSH-NIL N) (T O) (CONST K)
  891.      ; (2) statische Variablen
  892.      (LOAD K) (LOADI NNN) (LOADC NN) (LOADV NN) (LOADIC NNNN)
  893.      (STORE K) (STOREI NNN) (STOREC NN) (STOREV NN) (STOREIC NNNN)
  894.      ; (3) dynamische Variablen
  895.      (GETVALUE N) (SETVALUE N) (BIND N) (UNBIND1 O) (UNBIND N) (PROGV O)
  896.      ; (4) Stackoperationen
  897.      (PUSH O) (POP O) (SKIP N) (SKIPI NNN) (SKIPSP NN)
  898.      ; (5) Programmflu▀ und Sprⁿnge
  899.      (SKIP&RET N) (JMP L) (JMPIF L) (JMPIFNOT L) (JMPIF1 L) (JMPIFNOT1 L)
  900.      (JMPIFATOM L) (JMPIFCONSP L) (JMPIFEQ L) (JMPIFNOTEQ L)
  901.      (JMPIFEQTO NL) (JMPIFNOTEQTO NL) (JMPHASH NHL) (JMPHASHV NHL) (JSR L)
  902.      (JMPTAIL NNL)
  903.      ; (6) Environments und Closures
  904.      (VENV O) (MAKE-VECTOR1&PUSH N) (COPY-CLOSURE NN)
  905.      ; (7) Funktionsaufrufe
  906.      (CALL NN) (CALL0 N) (CALL1 N) (CALL2 N)
  907.      (CALLS1 B) (CALLS2 B) (CALLSR NB) (CALLC O) (CALLCKEY O)
  908.      (FUNCALL N) (APPLY N)
  909.      ; (8) optionale und Keyword-Argumente
  910.      (PUSH-UNBOUND N) (UNLIST NN) (UNLIST* NN) (JMPIFBOUNDP NL) (BOUNDP N)
  911.      (UNBOUND->NIL N)
  912.      ; (9) Behandlung mehrerer Werte
  913.      (VALUES0 O) (VALUES1 O) (STACK-TO-MV N) (MV-TO-STACK O) (NV-TO-STACK N)
  914.      (MV-TO-LIST O) (LIST-TO-MV O) (MVCALLP O) (MVCALL O)
  915.      ; (10) BLOCK
  916.      (BLOCK-OPEN NL) (BLOCK-CLOSE O) (RETURN-FROM N) (RETURN-FROM-I NNN)
  917.      ; (11) TAGBODY
  918.      (TAGBODY-OPEN NLX) (TAGBODY-CLOSE-NIL O) (TAGBODY-CLOSE O) (GO NN)
  919.      (GO-I NNNN)
  920.      ; (12) CATCH und THROW
  921.      (CATCH-OPEN L) (CATCH-CLOSE O) (THROW O)
  922.      ; (13) UNWIND-PROTECT
  923.      (UNWIND-PROTECT-OPEN L) (UNWIND-PROTECT-NORMAL-EXIT O)
  924.      (UNWIND-PROTECT-CLOSE O) (UNWIND-PROTECT-CLEANUP O)
  925.      ; (14) HANDLER
  926.      (HANDLER-OPEN NC) (HANDLER-BEGIN&PUSH O)
  927.      ; (15) einige Funktionen
  928.      (NOT O) (EQ O) (CAR O) (CDR O) (CONS O) (SYMBOL-FUNCTION O) (SVREF O)
  929.      (SVSET O) (LIST N) (LIST* N)
  930.      ; (16) kombinierte Operationen
  931.      (NIL&PUSH O) (T&PUSH O) (CONST&PUSH K)
  932.      (LOAD&PUSH K) (LOADI&PUSH NNN) (LOADC&PUSH NN) (LOADV&PUSH NN) (POP&STORE N)
  933.      (GETVALUE&PUSH N)
  934.      (JSR&PUSH L)
  935.      (COPY-CLOSURE&PUSH NN)
  936.      (CALL&PUSH NN) (CALL1&PUSH N) (CALL2&PUSH N)
  937.      (CALLS1&PUSH B) (CALLS2&PUSH B) (CALLSR&PUSH NB)
  938.      (CALLC&PUSH O) (CALLCKEY&PUSH O)
  939.      (FUNCALL&PUSH N) (APPLY&PUSH N)
  940.      (CAR&PUSH O) (CDR&PUSH O) (CONS&PUSH O)
  941.      (LIST&PUSH N) (LIST*&PUSH N)
  942.      (NIL&STORE N) (T&STORE N) (LOAD&STOREC NNN)
  943.      (CALLS1&STORE BN) (CALLS2&STORE BN) (CALLSR&STORE NBN)
  944.      (LOAD&CDR&STORE N) (LOAD&CONS&STORE N) (LOAD&INC&STORE N) (LOAD&DEC&STORE N)
  945.      (LOAD&CAR&STORE NN)
  946.      (CALL1&JMPIF NL) (CALL1&JMPIFNOT NL)
  947.      (CALL2&JMPIF NL) (CALL2&JMPIFNOT NL)
  948.      (CALLS1&JMPIF BL) (CALLS1&JMPIFNOT BL)
  949.      (CALLS2&JMPIF BL) (CALLS2&JMPIFNOT BL)
  950.      (CALLSR&JMPIF NBL) (CALLSR&JMPIFNOT NBL)
  951.      (LOAD&JMPIF NL) (LOAD&JMPIFNOT NL)
  952.      (LOAD&CAR&PUSH N) (LOAD&CDR&PUSH N) (LOAD&INC&PUSH N) (LOAD&DEC&PUSH N)
  953.      (CONST&SYMBOL-FUNCTION N) (CONST&SYMBOL-FUNCTION&PUSH N)
  954.      (CONST&SYMBOL-FUNCTION&STORE NN)
  955.      (APPLY&SKIP&RET NN)
  956. )   )
  957. (dotimes (i (length instruction-table))
  958.   (setf (get (first (svref instruction-table i)) 'INSTRUCTION) i)
  959. )
  960. (defconstant instruction-codes
  961.   (let ((hashtable (make-hash-table :test #'eq)))
  962.     (dotimes (i (length instruction-table))
  963.       (setf (gethash (first (svref instruction-table i)) hashtable) i)
  964.     )
  965.     hashtable
  966. ) )
  967.  
  968. ; K-Instruktionen:
  969. (defconstant instruction-table-K
  970.   '#(LOAD LOAD&PUSH CONST CONST&PUSH STORE)
  971. )
  972. (defconstant short-code-base 155)
  973. (defconstant short-code-opsize '#(15   25   21   30   10))
  974. (defconstant short-code-ops '#(155  170  195  216  246));256
  975.  
  976.  
  977. #|
  978.  
  979. Zwischensprache nach dem 1. Pass:
  980. =================================
  981.  
  982. 1. Konstanten:
  983.  
  984. (NIL)                            A0 := NIL, 1 Wert
  985.  
  986. (PUSH-NIL n)                     n-mal: -(STACK) := NIL, undefinierte Werte
  987.  
  988. (T)                              A0 := T, 1 Wert
  989.  
  990. (CONST const)                    A0 := 'const, 1 Wert
  991.  
  992. (FCONST fnode)                   A0 := das Compilat des fnode, 1 Wert
  993.  
  994. (BCONST block)                   A0 := das Block-Cons dieses Blockes (eine
  995.                                  Konstante aus FUNC), 1 Wert
  996.  
  997. (GCONST tagbody)                 A0 := das Tagbody-Cons dieses Tagbody (eine
  998.                                  Konstante aus FUNC), 1 Wert
  999.  
  1000. 2.,3. Variablen:
  1001.  
  1002. (GET var venvc stackz)           A0 := var, 1 Wert
  1003.                                  (venvc ist das aktuelle Closure-Venv,
  1004.                                   stackz der aktuelle Stackzustand)
  1005.  
  1006. (SET var venvc stackz)           var := A0, 1 Wert
  1007.                                  (venvc ist das aktuelle Closure-Venv,
  1008.                                   stackz der aktuelle Stackzustand)
  1009.  
  1010. (STORE n)                        (STACK+4*n) := A0, 1 Wert
  1011.  
  1012. (GETVALUE symbol)                A0 := (symbol-value 'symbol), 1 Wert
  1013.  
  1014. (SETVALUE symbol)                (setf (symbol-value 'symbol) A0), 1 Wert
  1015.  
  1016. (BIND const)                     bindet const (ein Symbol) dynamisch an A0.
  1017.                                  Undefinierte Werte.
  1018.  
  1019. (UNBIND1)                        l÷st einen Bindungsframe auf
  1020.  
  1021. (PROGV)                          bindet dynamisch die Symbole in der Liste
  1022.                                  (STACK)+ an die Werte in der Liste A0 und
  1023.                                  baut dabei genau einen Bindungsframe auf,
  1024.                                  undefinierte Werte
  1025.  
  1026. 4. Stackoperationen:
  1027.  
  1028. (PUSH)                           -(STACK) := A0, undefinierte Werte
  1029.  
  1030. (POP)                            A0 := (STACK)+, 1 Wert
  1031.  
  1032. (UNWIND stackz1 stackz2 for-value) Fⁿhrt ein Unwind binnen einer Funktion aus:
  1033.                                  Bereinigt den Stack, um vom Stackzustand
  1034.                                  stackz1 zum Stackzustand stackz2 zu kommen.
  1035.                                  L÷st dazwischen liegende Frames auf. for-value
  1036.                                  gibt an, ob dabei die Werte A0/... gerettet
  1037.                                  werden mⁿssen.
  1038.  
  1039. (UNWINDSP stackz1 stackz2)       modifiziert den SP, um vom Stackzustand
  1040.                                  stackz1 zum Stackzustand stackz2 zu kommen.
  1041.                                  STACK und die Werte A0/... bleiben unverΣndert.
  1042.  
  1043. 5. Programmflu▀ und Sprⁿnge:
  1044.  
  1045. (RET)                            beendet die Funktion mit den Werten A0/...
  1046.  
  1047. (JMP label)                      Sprung zu label
  1048.  
  1049. (JMPIF label)                    falls A0 /= NIL : Sprung zu label.
  1050.  
  1051. (JMPIFNOT label)                 falls A0 = NIL : Sprung zu label.
  1052.  
  1053. (JMPIF1 label)                   falls A0 /= NIL : 1 Wert, Sprung zu label.
  1054.  
  1055. (JMPIFNOT1 label)                falls A0 = NIL : 1 Wert, Sprung zu label.
  1056.  
  1057. (JMPHASH test ((obj1 . label1) ... (objm . labelm)) label . labels)
  1058.                                  Sprung zu labeli, falls A0 = obji (im Sinne
  1059.                                  des angegebenen Vergleichs), sonst zu label.
  1060.                                  Undefinierte Werte.
  1061.  
  1062. (JSR m label)                    ruft den Code ab label als Unterprogramm auf,
  1063.                                  mit m Argumenten auf dem Stack
  1064.  
  1065. (BARRIER)                        wird nie erreicht, zΣhlt als Wegsprung
  1066.  
  1067. 6. Environments und Closures:
  1068.  
  1069. (VENV venvc stackz)              A0 := das Venv, das venvc entspricht
  1070.                                  (aus dem Stack, als Konstante aus
  1071.                                  FUNC, oder NIL, falls in FUNC nicht vorhanden),
  1072.                                  1 Wert
  1073.                                  (stackz ist der aktuelle Stackzustand)
  1074.  
  1075. (MAKE-VECTOR1&PUSH n)            kreiert einen simple-vector mit n+1 (n>=0)
  1076.                                  Komponenten und steckt A0 als Komponente 0
  1077.                                  hinein. -(STACK) := der neue Vektor.
  1078.                                  Undefinierte Werte.
  1079.  
  1080. (COPY-CLOSURE fnode n)           kopiert die Closure, die dem fnode entspricht
  1081.                                  und ersetzt in der Kopie fⁿr i=0,...,n-1 (n>0)
  1082.                                  die Komponente (CONST i) durch (STACK+4*(n-1-i)).
  1083.                                  STACK := STACK+4*n. A0 := Closure-Kopie, 1 Wert
  1084.  
  1085. 7. Funktionsaufrufe:
  1086.  
  1087. (CALLP)                          beginnt den Aufbau eines Funktionsaufruf-Frames
  1088.                                  (wird im 2. Pass ersatzlos gestrichen)
  1089.  
  1090. (CALL k const)                   ruft die Funktion const mit k Argumenten
  1091.                                  (STACK+4*(k-1)),...,(STACK+4*0) auf,
  1092.                                  STACK:=STACK+4*k, Ergebnis kommt nach A0/...
  1093.  
  1094. (CALL0 const)                    ruft die Funktion const mit 0 Argumenten auf,
  1095.                                  Ergebnis kommt nach A0/...
  1096.  
  1097. (CALL1 const)                    ruft die Funktion const mit 1 Argument A0 auf,
  1098.                                  Ergebnis kommt nach A0/...
  1099.  
  1100. (CALL2 const)                    ruft die Funktion const mit 2 Argumenten (STACK)
  1101.                                  und A0 auf, STACK:=STACK+4,
  1102.                                  Ergebnis kommt nach A0/...
  1103.  
  1104. (CALLS1 n)                       ruft die Funktion (FUNTAB n)
  1105. (CALLS2 n)                       bzw. (FUNTAB 256+n)
  1106.                                  (ein SUBR ohne Rest-Parameter) auf,
  1107.                                  mit der korrekten Argumentezahl auf dem STACK.
  1108.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1109.  
  1110. (CALLSR m n)                     ruft die Funktion (FUNTABR n)
  1111.                                  (ein SUBR mit Rest-Parameter) auf,
  1112.                                  mit der korrekten Argumentezahl und zusΣtzlich
  1113.                                  m restlichen Argumenten auf dem STACK.
  1114.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1115.  
  1116. (CALLC)                          ruft die Funktion A0 (eine compilierte Closure
  1117.                                  ohne Keyword-Parameter) auf. Argumente
  1118.                                  sind schon im richtigen Format auf dem STACK,
  1119.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1120.  
  1121. (CALLCKEY)                       ruft die Funktion A0 (eine compilierte Closure
  1122.                                  mit Keyword-Parameter) auf. Argumente
  1123.                                  sind schon im richtigen Format auf dem STACK,
  1124.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1125.  
  1126. (FUNCALLP)                       fΣngt den Aufbau eines FUNCALL-Frames an,
  1127.                                  auszufⁿhrende Funktion ist in A0
  1128.  
  1129. (FUNCALL n)                      ruft die angegebene Funktion mit n (n>=0)
  1130.                                  Argumenten (alle auf dem Stack) auf,
  1131.                                  beseitigt den FUNCALL-Frame,
  1132.                                  Ergebnis kommt nach A0/...
  1133.  
  1134. (APPLYP)                         fΣngt den Aufbau eines APPLY-Frames an,
  1135.                                  auszufⁿhrende Funktion ist in A0
  1136.  
  1137. (APPLY n)                        ruft die angegebene Funktion mit n (n>=0)
  1138.                                  Argumenten (alle auf dem Stack) und weiteren
  1139.                                  Argumenten (Liste in A0) auf,
  1140.                                  beseitigt den APPLY-Frame,
  1141.                                  Ergebnis kommt nach A0/...
  1142.  
  1143. 8. optionale und Keyword-Argumente:
  1144.  
  1145. (PUSH-UNBOUND n)                 n-mal: -(STACK) := #<UNBOUND>, undefinierte Werte
  1146.  
  1147. (UNLIST n m)                     Liste A0 n mal verkⁿrzen: -(STACK) := (car A0),
  1148.                                  A0 := (cdr A0). Bei den letzten m Mal darf A0
  1149.                                  schon zu Ende sein, dann -(STACK) := #<UNBOUND>
  1150.                                  stattdessen. Am Schlu▀ mu▀ A0 = NIL sein,
  1151.                                  undefinierte Werte. 0 <= m <= n.
  1152.  
  1153. (UNLIST* n m)                    Liste A0 n mal verkⁿrzen: -(STACK) := (car A0),
  1154.                                  A0 := (cdr A0). Bei den letzten m Mal darf A0
  1155.                                  schon zu Ende sein, dann -(STACK) := #<UNBOUND>.
  1156.                                  stattdessen. Dann -(STACK) := (nthcdr n A0),
  1157.                                  undefinierte Werte. 0 <= m <= n, n > 0.
  1158.  
  1159. (JMPIFBOUNDP var venvc stackz label)
  1160.                                  falls Variable /= #<UNBOUND> :
  1161.                                    Sprung zu label, A0 := Variable, 1 Wert.
  1162.                                  Sonst undefinierte Werte.
  1163.                                  (stackz ist der aktuelle Stackzustand)
  1164.  
  1165. (BOUNDP var venvc stackz)        A0 := (NIL falls Variable=#<UNBOUND>, T sonst),
  1166.                                  1 Wert
  1167.                                  (stackz ist der aktuelle Stackzustand)
  1168.  
  1169. 9. Behandlung mehrerer Werte:
  1170.  
  1171. (VALUES0)                        A0 := NIL, 0 Werte
  1172.  
  1173. (VALUES1)                        A0 := A0, 1 Wert
  1174.  
  1175. (STACK-TO-MV n)                  holt n Werte von (STACK)+ herab,
  1176.                                  STACK:=STACK+4*n, n>1
  1177.  
  1178. (MV-TO-STACK)                    Multiple Values A0/A1/... auf -(STACK),
  1179.                                  1. Wert zuoberst, STACK:=STACK-4*D7.W,
  1180.                                  danach undefinierte Werte
  1181.  
  1182. (NV-TO-STACK n)                  die ersten n Werte (n>=0) auf -(STACK),
  1183.                                  1. Wert zuoberst, STACK:=STACK-4*n,
  1184.                                  undefinierte Werte
  1185.  
  1186. (MV-TO-LIST)                     Multiple Values A0/... als Liste nach A0,
  1187.                                  1 Wert
  1188.  
  1189. (LIST-TO-MV)                     A0/... := (values-list A0)
  1190.  
  1191. (MVCALLP)                        bereitet einen MULTIPLE-VALUE-CALL auf die
  1192.                                  Funktion in A0 vor
  1193.  
  1194. (MVCALL)                         fⁿhrt einen MULTIPLE-VALUE-CALL mit den im
  1195.                                  Stack liegenden Argumenten aus
  1196.  
  1197. 10. BLOCK:
  1198.  
  1199. (BLOCK-OPEN const label)         Legt einen Block-Cons (mit CAR=const und CDR=
  1200.                                  Framepointer) auf -(STACK) ab, baut einen
  1201.                                  Block-Frame auf. Bei einem RETURN auf diesen
  1202.                                  Frame wird zu label gesprungen.
  1203.  
  1204. (BLOCK-CLOSE)                    Verlasse den Block und baue dabei einen Block-
  1205.                                  Frame ab (inklusive der Block-Cons-Variablen)
  1206.  
  1207. (RETURN-FROM const)              Verlasse den Block, dessen Block-Cons angegeben
  1208.                                  ist, mit den Werten A0/...
  1209. (RETURN-FROM block)              Verlasse den angegebenen Block (sein Block-Cons
  1210.                                  kommt unter den BlockConsts von FUNC vor) mit
  1211.                                  den Werten A0/...
  1212. (RETURN-FROM block stackz)       Verlasse den angegebenen Block (sein Block-Cons
  1213.                                  kommt im Stack vor) mit den Werten A0/...
  1214.  
  1215. 11. TAGBODY:
  1216.  
  1217. (TAGBODY-OPEN const label1 ... labelm)
  1218.                                  Legt einen Tagbody-Cons (mit CAR=const
  1219.                                  und CDR=Framepointer) auf -(STACK) ab, baut einen
  1220.                                  Tagbody-Frame auf. Bei einem GO mit Nummer l
  1221.                                  wird zu labell gesprungen.
  1222.  
  1223. (TAGBODY-CLOSE-NIL)              Verlasse den Tagbody und baue dabei einen
  1224.                                  Tagbody-Frame ab (inklusive der Tagbody-Cons-
  1225.                                  Variablen). A0 := NIL, 1 Wert
  1226.  
  1227. (TAGBODY-CLOSE)                  Verlasse den Tagbody und baue dabei einen
  1228.                                  Tagbody-Frame ab (inklusive der Tagbody-Cons-
  1229.                                  Variablen).
  1230.  
  1231. (GO const l)                     Springe im Tagbody, dessen Tagbody-Cons
  1232.                                  angegeben ist, an Tag (svref (car const) l)
  1233. (GO tagbody l)                   Springe im angegebenen Tagbody an Tag Nummer l
  1234.                                  in (tagbody-used-far tagbody)
  1235. (GO tagbody l stackz)            Springe im angegebenen Tagbody an Tag Nummer l
  1236.                                  in (tagbody-used-far tagbody), sein Tagbody-
  1237.                                  Cons liegt im Stack
  1238.  
  1239. 12. CATCH und THROW:
  1240.  
  1241. (CATCH-OPEN label)               baut einen CATCH-Frame auf mit A0 als Tag;
  1242.                                  bei einem THROW auf dieses Tag wird zu label
  1243.                                  gesprungen
  1244.  
  1245. (CATCH-CLOSE)                    l÷st einen CATCH-Frame auf
  1246.  
  1247. (THROW)                          fⁿhrt ein THROW auf den Catch-Tag (STACK)+
  1248.                                  aus, mit den Werten A0/...
  1249.  
  1250. 13. UNWIND-PROTECT:
  1251.  
  1252. (UNWIND-PROTECT-OPEN label)      baut einen UNWIND-PROTECT-Frame auf; bei einem
  1253.                                  Unwind wird unter Rettung der Werte zu label
  1254.                                  gesprungen
  1255.  
  1256. (UNWIND-PROTECT-NORMAL-EXIT)     l÷st einen Unwind-Protect-Frame auf, schreibt
  1257.                                  eine Weitermach-Adresse auf SP, rettet die
  1258.                                  Werte und fΣngt an, den folgenden Cleanup-Code
  1259.                                  auszufⁿhren
  1260.  
  1261. (UNWIND-PROTECT-CLOSE label)     beendet den Cleanup-Code: schreibt die
  1262.                                  geretteten Werte zurⁿck, fⁿhrt ein RTS aus.
  1263.                                  Der Cleanup-Code fΣngt bei label an.
  1264.  
  1265. (UNWIND-PROTECT-CLEANUP)         l÷st einen Unwind-Protect-Frame auf, schreibt
  1266.                                  eine Weitermach-Adresse und den PC auf SP,
  1267.                                  rettet die Werte und fΣngt an, den Cleanup-
  1268.                                  Code auszufⁿhren
  1269.  
  1270. 14. HANDLER:
  1271.  
  1272. (HANDLER-OPEN const stackz label1 ... labelm)
  1273.                                  baut einen HANDLER-Frame auf; const enthΣlt
  1274.                                  die Condition-Typen; die entsprechenden
  1275.                                  Handler beginnen bei labeli
  1276.  
  1277. (HANDLER-BEGIN)                  beginnt einen Handler: stellt den SP-Zustand
  1278.                                  wie beim HANDLER-OPEN her,
  1279.                                  A0 := dem Handler ⁿbergebene Condition, 1 Wert
  1280.  
  1281. 15. einige Funktionen:
  1282.  
  1283. (NOT)                            = (CALL1 #'NOT)
  1284.  
  1285. (EQ)                             = (CALL2 #'EQ)
  1286.  
  1287. (CAR)                            = (CALL1 #'CAR)
  1288.  
  1289. (CDR)                            = (CALL1 #'CDR)
  1290.  
  1291. (CONS)                           = (CALL2 #'CONS)
  1292.  
  1293. (ATOM)                           = (CALL1 #'ATOM)
  1294.  
  1295. (CONSP)                          = (CALL1 #'CONSP)
  1296.  
  1297. (SYMBOL-FUNCTION)                = (CALL1 #'SYMBOL-FUNCTION)
  1298.  
  1299. (SVREF)                          = (CALL2 #'SVREF)
  1300.  
  1301. (SVSET)                          (setf (svref (STACK) A0) (STACK+4)),
  1302.                                  A0 := (STACK+4), 1 Wert, STACK:=STACK+8
  1303.  
  1304. (LIST n)                         = (CALL n #'LIST), n>0
  1305.  
  1306. (LIST* n)                        = (CALL n+1 #'LIST*), n>0
  1307.  
  1308.  
  1309. Dabei bedeuten jeweils:
  1310.  
  1311. n, m, k     eine ganze Zahl >=0
  1312.  
  1313. stackz      einen Stackzustand (siehe STACK-VERWALTUNG).
  1314.             Das Stack-Layout steht nach dem 1. Pass fest.
  1315.  
  1316. venvc       das Environment der Closure-Variablen (siehe VARIABLEN-VERWALTUNG).
  1317.             Dies steht nach dem 1. Pass auch fest.
  1318.  
  1319. var         eine Variable (siehe VARIABLEN-VERWALTUNG). Ob sie
  1320.             special/konstant/lexikalisch ist, steht nach dem 1. Pass fest.
  1321.  
  1322. const       eine Konstante
  1323.  
  1324. symbol      ein Symbol
  1325.  
  1326. fun         entweder (CONST const) eine Konstante, die ein Symbol ist,
  1327.             oder (FUNTAB index) eine Indizierung in die feste Funktionentabelle.
  1328.  
  1329. fnode       ein fnode (siehe FUNKTIONEN-VERWALTUNG)
  1330.  
  1331. label       ein Label (uninterniertes Symbol)
  1332.  
  1333. block       ein Block-Descriptor (siehe BLOCK-VERWALTUNG)
  1334.  
  1335. test        EQ oder EQL oder EQUAL
  1336.  
  1337. for-value   NIL oder T
  1338.  
  1339. |#
  1340.  
  1341. #-CLISP ; Die Funktionentabelle steckt in EVAL.
  1342. (eval-when (compile load eval)
  1343.   ; die Funktionstabelle mit max. 3*256 Funktionen (spart Konstanten in FUNC) :
  1344.   (defconstant funtab
  1345.     '#(system::%funtabref system::subr-info
  1346.        sys::%copy-simple-vector #| svref system::%svstore |# row-major-aref
  1347.        system::row-major-store array-element-type array-rank array-dimension
  1348.        array-dimensions array-total-size adjustable-array-p bit-and bit-ior
  1349.        bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2 bit-orc1 bit-orc2
  1350.        bit-not array-has-fill-pointer-p fill-pointer system::set-fill-pointer
  1351.        vector-push vector-pop vector-push-extend make-array adjust-array
  1352.        standard-char-p graphic-char-p string-char-p alpha-char-p upper-case-p
  1353.        lower-case-p both-case-p digit-char-p alphanumericp char-code char-bits
  1354.        char-font code-char make-char character char-upcase char-downcase
  1355.        digit-char char-int int-char char-name char-bit set-char-bit char schar
  1356.        system::store-char system::store-schar string= string/= string< string>
  1357.        string<= string>= string-equal string-not-equal string-lessp
  1358.        string-greaterp string-not-greaterp string-not-lessp
  1359.        system::search-string= system::search-string-equal make-string
  1360.        system::string-both-trim nstring-upcase string-upcase nstring-downcase
  1361.        string-downcase nstring-capitalize string-capitalize string name-char
  1362.        substring
  1363.        symbol-value #| symbol-function |# boundp fboundp special-form-p set makunbound
  1364.        fmakunbound #| values-list |# system::driver system::unwind-to-driver
  1365.        macro-function macroexpand macroexpand-1 proclaim eval evalhook applyhook
  1366.        constantp system::parse-body system::keyword-test
  1367.        room
  1368.        invoke-debugger
  1369.        make-hash-table gethash system::puthash remhash maphash clrhash
  1370.        hash-table-count system::hash-table-iterator system::hash-table-iterate
  1371.        clos::class-gethash sxhash
  1372.        copy-readtable set-syntax-from-char set-macro-character
  1373.        get-macro-character make-dispatch-macro-character
  1374.        set-dispatch-macro-character get-dispatch-macro-character read
  1375.        read-preserving-whitespace read-delimited-list read-line read-char
  1376.        unread-char peek-char listen read-char-no-hang clear-input
  1377.        read-from-string parse-integer write prin1 print pprint princ
  1378.        write-to-string prin1-to-string princ-to-string write-char write-string
  1379.        write-line terpri fresh-line finish-output force-output clear-output
  1380.        system::line-position
  1381.        #| car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar
  1382.        cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
  1383.        cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr cons |# tree-equal endp
  1384.        list-length nth #| first second third fourth |# fifth sixth seventh eighth
  1385.        ninth tenth #| rest |# nthcdr last make-list copy-list copy-alist copy-tree
  1386.        revappend nreconc system::list-nreverse butlast nbutlast ldiff rplaca
  1387.        system::%rplaca rplacd system::%rplacd subst subst-if subst-if-not nsubst
  1388.        nsubst-if nsubst-if-not sublis nsublis member member-if member-if-not
  1389.        tailp adjoin acons pairlis assoc assoc-if assoc-if-not rassoc rassoc-if
  1390.        rassoc-if-not
  1391.        lisp-implementation-type lisp-implementation-version software-type
  1392.        software-version identity get-universal-time get-internal-run-time
  1393.        get-internal-real-time system::%sleep system::%%time
  1394.        make-symbol find-package package-name package-nicknames rename-package
  1395.        package-use-list package-used-by-list package-shadowing-symbols
  1396.        list-all-packages intern find-symbol unintern export unexport import
  1397.        shadowing-import shadow use-package unuse-package make-package
  1398.        system::%in-package in-package find-all-symbols system::map-symbols
  1399.        system::map-external-symbols system::map-all-symbols
  1400.        parse-namestring pathname pathname-host pathname-device
  1401.        pathname-directory pathname-name pathname-type pathname-version
  1402.        file-namestring directory-namestring host-namestring merge-pathnames
  1403.        enough-namestring make-pathname namestring truename probe-file
  1404.        delete-file rename-file open directory cd make-dir delete-dir
  1405.        file-write-date file-author savemem
  1406.        #| eq |# eql equal equalp consp atom symbolp stringp numberp
  1407.        compiled-function-p #| null not |# system::closurep listp integerp
  1408.        system::fixnump rationalp floatp system::short-float-p
  1409.        system::single-float-p system::double-float-p system::long-float-p
  1410.        realp complexp streamp random-state-p readtablep hash-table-p pathnamep
  1411.        system::logical-pathname-p characterp functionp clos::generic-function-p
  1412.        packagep arrayp system::simple-array-p bit-vector-p vectorp
  1413.        simple-vector-p simple-string-p simple-bit-vector-p commonp type-of
  1414.        clos:class-of clos:find-class coerce
  1415.        system::%record-ref system::%record-store system::%record-length
  1416.        system::%structure-ref system::%structure-store system::%make-structure
  1417.        system::%copy-structure system::%structure-type-p system::closure-name
  1418.        system::closure-codevec system::closure-consts system::make-code-vector
  1419.        system::%make-closure system::make-load-time-eval
  1420.        clos::structure-instance-p clos::std-instance-p
  1421.        clos::%allocate-instance clos:slot-value clos::set-slot-value
  1422.        clos:slot-boundp clos:slot-makunbound clos:slot-exists-p
  1423.        system::sequencep elt system::%setelt subseq copy-seq length reverse
  1424.        nreverse make-sequence reduce fill replace remove remove-if remove-if-not
  1425.        delete delete-if delete-if-not remove-duplicates delete-duplicates
  1426.        substitute substitute-if substitute-if-not nsubstitute nsubstitute-if
  1427.        nsubstitute-if-not find find-if find-if-not position position-if
  1428.        position-if-not count count-if count-if-not mismatch search sort
  1429.        stable-sort merge
  1430.        system::file-stream-p make-synonym-stream system::synonym-stream-p
  1431.        system::broadcast-stream-p system::concatenated-stream-p
  1432.        make-two-way-stream system::two-way-stream-p make-echo-stream
  1433.        system::echo-stream-p make-string-input-stream
  1434.        system::string-input-stream-index make-string-output-stream
  1435.        get-output-stream-string system::make-string-push-stream
  1436.        system::string-stream-p input-stream-p output-stream-p
  1437.        stream-element-type close read-byte write-byte file-position file-length
  1438.        system::%putd system::%proclaim-constant get getf get-properties
  1439.        system::%putplist system::%put remprop symbol-package symbol-plist
  1440.        symbol-name keywordp gensym system::special-variable-p gensym
  1441.        system::decimal-string zerop plusp minusp oddp evenp 1+ 1- conjugate exp
  1442.        expt log sqrt isqrt abs phase signum sin cos tan cis asin acos atan sinh
  1443.        cosh tanh asinh acosh atanh float rational rationalize numerator
  1444.        denominator floor ceiling truncate round mod rem ffloor fceiling
  1445.        ftruncate fround decode-float scale-float float-radix float-sign
  1446.        float-digits float-precision integer-decode-float complex realpart
  1447.        imagpart lognand lognor logandc1 logandc2 logorc1 logorc2 boole lognot
  1448.        logtest logbitp ash logcount integer-length byte byte-size byte-position
  1449.        ldb ldb-test mask-field dpb deposit-field random make-random-state !
  1450.        exquo long-float-digits system::%set-long-float-digits system::log2
  1451.        system::log10
  1452.        vector aref system::store array-in-bounds-p array-row-major-index bit
  1453.        sbit char= char/= char< char> char<= char>= char-equal char-not-equal
  1454.        char-lessp char-greaterp char-not-greaterp char-not-lessp string-concat
  1455.        apply system::%funcall funcall mapcar maplist mapc mapl mapcan mapcon
  1456.        values error system::error-of-type clos::class-tuple-gethash list list*
  1457.        append nconc concatenate map some every notany notevery
  1458.        make-broadcast-stream make-concatenated-stream = /= < > <= >= max min
  1459.        + - * / gcd lcm logior logxor logand logeqv
  1460.   )   )
  1461.   (defun %funtabref (index)
  1462.     (if (and (<= 0 index) (< index (length funtab))) (svref funtab index) nil)
  1463.   )
  1464. )
  1465. #+CROSS
  1466. (eval-when (compile load eval)
  1467.   (defun subr-info (sym)
  1468.     (values-list
  1469.       (assoc sym
  1470.         '(; Das ist die Tabelle aller SUBRs, wie in SUBR.D.
  1471.           ; SUBRs, die in verschiedenen Implementationen verschiedene
  1472.           ; Signaturen haben und/oder deren Spezifikation sich noch Σndern
  1473.           ; k÷nnte, sind dabei allerdings auskommentiert.
  1474.           (! 1 0 nil nil nil)
  1475.           (system::%%time 0 0 nil nil nil)
  1476.           (system::%copy-structure 1 0 nil nil nil)
  1477.           (system::%defseq 1 0 nil nil nil)
  1478.           (system::%exit 0 1 nil nil nil)
  1479.           (system::%funcall 1 0 t nil nil)
  1480.           (system::%funtabref 1 0 nil nil nil)
  1481.           (system::%in-package 1 0 nil (:nicknames :use) nil)
  1482.           (system::%make-closure 3 0 nil nil nil)
  1483.           (system::%make-structure 2 0 nil nil nil)
  1484.           (system::%proclaim-constant 2 0 nil nil nil)
  1485.           (system::%put 3 0 nil nil nil)
  1486.           (system::%putd 2 0 nil nil nil)
  1487.           (system::%putplist 2 0 nil nil nil)
  1488.           (system::%record-length 1 0 nil nil nil)
  1489.           (system::%record-ref 2 0 nil nil nil)
  1490.           (system::%record-store 3 0 nil nil nil)
  1491.           (system::%rplaca 2 0 nil nil nil)
  1492.           (system::%rplacd 2 0 nil nil nil)
  1493.           (system::%set-long-float-digits 1 0 nil nil nil)
  1494.           (system::%setelt 3 0 nil nil nil)
  1495.           ;(system::%sleep 1 0 nil nil nil)
  1496.           ;(system::%sleep 2 0 nil nil nil)
  1497.           (system::%structure-ref 3 0 nil nil nil)
  1498.           (system::%structure-store 4 0 nil nil nil)
  1499.           (system::%structure-type-p 2 0 nil nil nil)
  1500.           (system::%svstore 3 0 nil nil nil)
  1501.           (* 0 0 t nil nil)
  1502.           (+ 0 0 t nil nil)
  1503.           (- 1 0 t nil nil)
  1504.           (/ 1 0 t nil nil)
  1505.           (/= 1 0 t nil nil)
  1506.           (1+ 1 0 nil nil nil)
  1507.           (1- 1 0 nil nil nil)
  1508.           (< 1 0 t nil nil)
  1509.           (<= 1 0 t nil nil)
  1510.           (= 1 0 t nil nil)
  1511.           (> 1 0 t nil nil)
  1512.           (>= 1 0 t nil nil)
  1513.           (abs 1 0 nil nil nil)
  1514.           (acons 3 0 nil nil nil)
  1515.           (acos 1 0 nil nil nil)
  1516.           (acosh 1 0 nil nil nil)
  1517.           (adjoin 2 0 nil (:test :test-not :key) nil)
  1518.           (adjust-array 2 0 nil (:element-type :initial-element :initial-contents :fill-pointer :displaced-to :displaced-index-offset) nil)
  1519.           (adjustable-array-p 1 0 nil nil nil)
  1520.           (alpha-char-p 1 0 nil nil nil)
  1521.           (alphanumericp 1 0 nil nil nil)
  1522.           (append 0 0 t nil nil)
  1523.           (apply 2 0 t nil nil)
  1524.           (applyhook 4 1 nil nil nil)
  1525.           (aref 1 0 t nil nil)
  1526.           (array-dimension 2 0 nil nil nil)
  1527.           (array-dimensions 1 0 nil nil nil)
  1528.           (array-element-type 1 0 nil nil nil)
  1529.           (array-has-fill-pointer-p 1 0 nil nil nil)
  1530.           (array-in-bounds-p 1 0 t nil nil)
  1531.           (array-rank 1 0 nil nil nil)
  1532.           (system::array-reader 3 0 nil nil nil)
  1533.           (array-row-major-index 1 0 t nil nil)
  1534.           (array-total-size 1 0 nil nil nil)
  1535.           (arrayp 1 0 nil nil nil)
  1536.           (ash 2 0 nil nil nil)
  1537.           (asin 1 0 nil nil nil)
  1538.           (asinh 1 0 nil nil nil)
  1539.           (assoc 2 0 nil (:test :test-not :key) nil)
  1540.           (assoc-if 2 0 nil (:key) nil)
  1541.           (assoc-if-not 2 0 nil (:key) nil)
  1542.           (atan 1 1 nil nil nil)
  1543.           (atanh 1 0 nil nil nil)
  1544.           (atom 1 0 nil nil nil)
  1545.           (system::binary-reader 3 0 nil nil nil)
  1546.           (bit 1 0 t nil nil)
  1547.           (bit-and 2 1 nil nil nil)
  1548.           (bit-andc1 2 1 nil nil nil)
  1549.           (bit-andc2 2 1 nil nil nil)
  1550.           (bit-eqv 2 1 nil nil nil)
  1551.           (bit-ior 2 1 nil nil nil)
  1552.           (bit-nand 2 1 nil nil nil)
  1553.           (bit-nor 2 1 nil nil nil)
  1554.           (bit-not 1 1 nil nil nil)
  1555.           (bit-orc1 2 1 nil nil nil)
  1556.           (bit-orc2 2 1 nil nil nil)
  1557.           (bit-vector-p 1 0 nil nil nil)
  1558.           (system::bit-vector-reader 3 0 nil nil nil)
  1559.           (bit-xor 2 1 nil nil nil)
  1560.           (boole 3 0 nil nil nil)
  1561.           (both-case-p 1 0 nil nil nil)
  1562.           (boundp 1 0 nil nil nil)
  1563.           (system::broadcast-stream-p 1 0 nil nil nil)
  1564.           (butlast 1 1 nil nil nil)
  1565.           (byte 2 0 nil nil nil)
  1566.           (byte-position 1 0 nil nil nil)
  1567.           (byte-size 1 0 nil nil nil)
  1568.           (caaaar 1 0 nil nil nil)
  1569.           (caaadr 1 0 nil nil nil)
  1570.           (caaar 1 0 nil nil nil)
  1571.           (caadar 1 0 nil nil nil)
  1572.           (caaddr 1 0 nil nil nil)
  1573.           (caadr 1 0 nil nil nil)
  1574.           (caar 1 0 nil nil nil)
  1575.           (cadaar 1 0 nil nil nil)
  1576.           (cadadr 1 0 nil nil nil)
  1577.           (cadar 1 0 nil nil nil)
  1578.           (caddar 1 0 nil nil nil)
  1579.           (cadddr 1 0 nil nil nil)
  1580.           (caddr 1 0 nil nil nil)
  1581.           (cadr 1 0 nil nil nil)
  1582.           (car 1 0 nil nil nil)
  1583.           (cd 0 1 nil nil nil)
  1584.           (cdaaar 1 0 nil nil nil)
  1585.           (cdaadr 1 0 nil nil nil)
  1586.           (cdaar 1 0 nil nil nil)
  1587.           (cdadar 1 0 nil nil nil)
  1588.           (cdaddr 1 0 nil nil nil)
  1589.           (cdadr 1 0 nil nil nil)
  1590.           (cdar 1 0 nil nil nil)
  1591.           (cddaar 1 0 nil nil nil)
  1592.           (cddadr 1 0 nil nil nil)
  1593.           (cddar 1 0 nil nil nil)
  1594.           (cdddar 1 0 nil nil nil)
  1595.           (cddddr 1 0 nil nil nil)
  1596.           (cdddr 1 0 nil nil nil)
  1597.           (cddr 1 0 nil nil nil)
  1598.           (cdr 1 0 nil nil nil)
  1599.           (ceiling 1 1 nil nil nil)
  1600.           (char 2 0 nil nil nil)
  1601.           (char-bit 2 0 nil nil nil)
  1602.           (char-bits 1 0 nil nil nil)
  1603.           (char-code 1 0 nil nil nil)
  1604.           (char-downcase 1 0 nil nil nil)
  1605.           (char-equal 1 0 t nil nil)
  1606.           (char-font 1 0 nil nil nil)
  1607.           (char-greaterp 1 0 t nil nil)
  1608.           (char-int 1 0 nil nil nil)
  1609.           (char-lessp 1 0 t nil nil)
  1610.           (char-name 1 0 nil nil nil)
  1611.           (char-not-equal 1 0 t nil nil)
  1612.           (char-not-greaterp 1 0 t nil nil)
  1613.           (char-not-lessp 1 0 t nil nil)
  1614.           (system::char-reader 3 0 nil nil nil)
  1615.           (char-upcase 1 0 nil nil nil)
  1616.           (char/= 1 0 t nil nil)
  1617.           (char< 1 0 t nil nil)
  1618.           (char<= 1 0 t nil nil)
  1619.           (char= 1 0 t nil nil)
  1620.           (char> 1 0 t nil nil)
  1621.           (char>= 1 0 t nil nil)
  1622.           (character 1 0 nil nil nil)
  1623.           (characterp 1 0 nil nil nil)
  1624.           (cis 1 0 nil nil nil)
  1625.           (clos::class-gethash 2 0 nil nil nil)
  1626.           (clos:class-of 1 0 nil nil nil)
  1627.           (clos::class-p 1 0 nil nil nil)
  1628.           (clos::class-tuple-gethash 2 0 t nil nil)
  1629.           (clear-input 0 1 nil nil nil)
  1630.           (clear-output 0 1 nil nil nil)
  1631.           (close 1 0 nil (:abort) nil)
  1632.           (system::closure-codevec 1 0 nil nil nil)
  1633.           (system::closure-consts 1 0 nil nil nil)
  1634.           (system::closure-name 1 0 nil nil nil)
  1635.           (system::closure-reader 3 0 nil nil nil)
  1636.           (system::closurep 1 0 nil nil nil)
  1637.           (clrhash 1 0 nil nil nil)
  1638.           (code-char 1 2 nil nil nil)
  1639.           (coerce 2 0 nil nil nil)
  1640.           (system::comment-reader 3 0 nil nil nil)
  1641.           (commonp 1 0 nil nil nil)
  1642.           (compiled-function-p 1 0 nil nil nil)
  1643.           (complex 1 1 nil nil nil)
  1644.           (system::complex-reader 3 0 nil nil nil)
  1645.           (complexp 1 0 nil nil nil)
  1646.           (concatenate 1 0 t nil nil)
  1647.           (system::concatenated-stream-p 1 0 nil nil nil)
  1648.           (conjugate 1 0 nil nil nil)
  1649.           (cons 2 0 nil nil nil)
  1650.           (consp 1 0 nil nil nil)
  1651.           (constantp 1 0 nil nil nil)
  1652.           (copy-alist 1 0 nil nil nil)
  1653.           (copy-list 1 0 nil nil nil)
  1654.           (copy-readtable 0 2 nil nil nil)
  1655.           (copy-seq 1 0 nil nil nil)
  1656.           (system::%copy-simple-vector 1 0 nil nil nil)
  1657.           (copy-tree 1 0 nil nil nil)
  1658.           (cos 1 0 nil nil nil)
  1659.           (cosh 1 0 nil nil nil)
  1660.           (count 2 0 nil (:from-end :start :end :key :test :test-not) nil)
  1661.           (count-if 2 0 nil (:from-end :start :end :key) nil)
  1662.           (count-if-not 2 0 nil (:from-end :start :end :key) nil)
  1663.           (system::debug 0 0 nil nil nil)
  1664.           (system::decimal-string 1 0 nil nil nil)
  1665.           (decode-float 1 0 nil nil nil)
  1666.           (delete 2 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  1667.           (delete-dir 1 0 nil nil nil)
  1668.           (delete-duplicates 1 0 nil (:from-end :start :end :key :test :test-not) nil)
  1669.           (delete-file 1 0 nil nil nil)
  1670.           (delete-if 2 0 nil (:from-end :start :end :key :count) nil)
  1671.           (delete-if-not 2 0 nil (:from-end :start :end :key :count) nil)
  1672.           (denominator 1 0 nil nil nil)
  1673.           (deposit-field 3 0 nil nil nil)
  1674.           (system::describe-frame 2 0 nil nil nil)
  1675.           (digit-char 1 2 nil nil nil)
  1676.           (digit-char-p 1 1 nil nil nil)
  1677.           (directory 0 1 nil (:circle :full) nil)
  1678.           (directory-namestring 1 0 nil nil nil)
  1679.           (system::double-float-p 1 0 nil nil nil)
  1680.           (dpb 3 0 nil nil nil)
  1681.           (system::driver 1 0 nil nil nil)
  1682.           (system::echo-stream-p 1 0 nil nil nil)
  1683.           (eighth 1 0 nil nil nil)
  1684.           (elt 2 0 nil nil nil)
  1685.           (endp 1 0 nil nil nil)
  1686.           (enough-namestring 1 1 nil nil nil)
  1687.           (eq 2 0 nil nil nil)
  1688.           (eql 2 0 nil nil nil)
  1689.           (equal 2 0 nil nil nil)
  1690.           (equalp 2 0 nil nil nil)
  1691.           (error 1 0 t nil nil)
  1692.           (system::error-of-type 2 0 t nil nil)
  1693.           (eval 1 0 nil nil nil)
  1694.           (system::eval-at 2 0 nil nil nil)
  1695.           (system::eval-frame-p 1 0 nil nil nil)
  1696.           (evalhook 3 1 nil nil nil)
  1697.           (evenp 1 0 nil nil nil)
  1698.           (every 2 0 t nil nil)
  1699.           ;(execute 1 2 nil nil nil)
  1700.           ;(execute 1 0 t nil nil)
  1701.           (exp 1 0 nil nil nil)
  1702.           (export 1 1 nil nil nil)
  1703.           (expt 2 0 nil nil nil)
  1704.           (exquo 2 0 nil nil nil)
  1705.           (fboundp 1 0 nil nil nil)
  1706.           (fceiling 1 1 nil nil nil)
  1707.           (system::feature-reader 3 0 nil nil nil)
  1708.           (ffloor 1 1 nil nil nil)
  1709.           (fifth 1 0 nil nil nil)
  1710.           (file-author 1 0 nil nil nil)
  1711.           (file-length 1 0 nil nil nil)
  1712.           (file-namestring 1 0 nil nil nil)
  1713.           (file-position 1 1 nil nil nil)
  1714.           (system::file-stream-p 1 0 nil nil nil)
  1715.           (file-write-date 1 0 nil nil nil)
  1716.           (fill 2 0 nil (:start :end) nil)
  1717.           (fill-pointer 1 0 nil nil nil)
  1718.           (find 2 0 nil (:from-end :start :end :key :test :test-not) nil)
  1719.           (find-all-symbols 1 0 nil nil nil)
  1720.           (clos:find-class 1 2 nil nil nil)
  1721.           (find-if 2 0 nil (:from-end :start :end :key) nil)
  1722.           (find-if-not 2 0 nil (:from-end :start :end :key) nil)
  1723.           (find-package 1 0 nil nil nil)
  1724.           (find-symbol 1 1 nil nil nil)
  1725.           (finish-output 0 1 nil nil nil)
  1726.           (first 1 0 nil nil nil)
  1727.           (system::fixnump 1 0 nil nil nil)
  1728.           (float 1 1 nil nil nil)
  1729.           (float-digits 1 1 nil nil nil)
  1730.           (float-precision 1 0 nil nil nil)
  1731.           (float-radix 1 0 nil nil nil)
  1732.           (float-sign 1 1 nil nil nil)
  1733.           (floatp 1 0 nil nil nil)
  1734.           (floor 1 1 nil nil nil)
  1735.           (fmakunbound 1 0 nil nil nil)
  1736.           (force-output 0 1 nil nil nil)
  1737.           (fourth 1 0 nil nil nil)
  1738.           (system::frame-down 2 0 nil nil nil)
  1739.           (system::frame-down-1 2 0 nil nil nil)
  1740.           (system::frame-up 2 0 nil nil nil)
  1741.           (system::frame-up-1 2 0 nil nil nil)
  1742.           (fresh-line 0 1 nil nil nil)
  1743.           (fround 1 1 nil nil nil)
  1744.           (ftruncate 1 1 nil nil nil)
  1745.           (funcall 1 0 t nil nil)
  1746.           (system::function-reader 3 0 nil nil nil)
  1747.           (functionp 1 0 nil nil nil)
  1748.           (gc 0 0 nil nil nil)
  1749.           (gcd 0 0 t nil nil)
  1750.           (clos::generic-function-p 1 0 nil nil nil)
  1751.           (gensym 0 1 nil nil nil)
  1752.           (get 2 1 nil nil nil)
  1753.           (get-dispatch-macro-character 2 1 nil nil nil)
  1754.           (get-internal-real-time 0 0 nil nil nil)
  1755.           (get-internal-run-time 0 0 nil nil nil)
  1756.           (get-macro-character 1 1 nil nil nil)
  1757.           (get-output-stream-string 1 0 nil nil nil)
  1758.           (get-properties 2 0 nil nil nil)
  1759.           (get-universal-time 0 0 nil nil nil)
  1760.           (getf 2 1 nil nil nil)
  1761.           (gethash 2 1 nil nil nil)
  1762.           (graphic-char-p 1 0 nil nil nil)
  1763.           (hash-table-count 1 0 nil nil nil)
  1764.           (hash-table-rehash-size 1 0 nil nil nil)
  1765.           (hash-table-rehash-threshold 1 0 nil nil nil)
  1766.           (hash-table-size 1 0 nil nil nil)
  1767.           (hash-table-test 1 0 nil nil nil)
  1768.           (system::hash-table-iterate 1 0 nil nil nil)
  1769.           (system::hash-table-iterator 1 0 nil nil nil)
  1770.           (hash-table-p 1 0 nil nil nil)
  1771.           (system::hexadecimal-reader 3 0 nil nil nil)
  1772.           (host-namestring 1 0 nil nil nil)
  1773.           (identity 1 0 nil nil nil)
  1774.           (imagpart 1 0 nil nil nil)
  1775.           (import 1 1 nil nil nil)
  1776.           (in-package 1 0 nil (:nicknames :use) nil)
  1777.           (system::initial-contents-aux 1 0 nil nil nil)
  1778.           (input-stream-p 1 0 nil nil nil)
  1779.           (int-char 1 0 nil nil nil)
  1780.           (integer-decode-float 1 0 nil nil nil)
  1781.           (integer-length 1 0 nil nil nil)
  1782.           (integerp 1 0 nil nil nil)
  1783.           (intern 1 1 nil nil nil)
  1784.           (invoke-debugger 1 0 nil nil nil)
  1785.           (isqrt 1 0 nil nil nil)
  1786.           (system::keyword-test 2 0 nil nil nil)
  1787.           (keywordp 1 0 nil nil nil)
  1788.           (system::label-definiion-reader 3 0 nil nil nil)
  1789.           (system::label-reference-reader 3 0 nil nil nil)
  1790.           (last 1 1 nil nil nil)
  1791.           (lcm 0 0 t nil nil)
  1792.           (ldb 2 0 nil nil nil)
  1793.           (ldb-test 2 0 nil nil nil)
  1794.           (ldiff 2 0 nil nil nil)
  1795.           (length 1 0 nil nil nil)
  1796.           (system::line-comment-reader 2 0 nil nil nil)
  1797.           (system::line-number 1 0 nil nil nil)
  1798.           (system::line-position 0 1 nil nil nil)
  1799.           (lisp-implementation-type 0 0 nil nil nil)
  1800.           (lisp-implementation-version 0 0 nil nil nil)
  1801.           (list 0 0 t nil nil)
  1802.           (list* 1 0 t nil nil)
  1803.           (system::list-access 2 0 nil nil nil)
  1804.           (system::list-access-set 3 0 nil nil nil)
  1805.           (list-all-packages 0 0 nil nil nil)
  1806.           (system::list-elt 2 0 nil nil nil)
  1807.           (system::list-endtest 2 0 nil nil nil)
  1808.           (system::list-fe-init 1 0 nil nil nil)
  1809.           (system::list-fe-init-end 2 0 nil nil nil)
  1810.           (system::list-init-start 2 0 nil nil nil)
  1811.           (list-length 1 0 nil nil nil)
  1812.           (system::list-llength 1 0 nil nil nil)
  1813.           (system::list-nreverse 1 0 nil nil nil)
  1814.           (system::list-set-elt 3 0 nil nil nil)
  1815.           (system::list-upd 2 0 nil nil nil)
  1816.           (listen 0 1 nil nil nil)
  1817.           (listp 1 0 nil nil nil)
  1818.           (system::load-eval-reader 3 0 nil nil nil)
  1819.           (log 1 1 nil nil nil)
  1820.           (system::log10 1 0 nil nil nil)
  1821.           (system::log2 1 0 nil nil nil)
  1822.           (logand 0 0 t nil nil)
  1823.           (logandc1 2 0 nil nil nil)
  1824.           (logandc2 2 0 nil nil nil)
  1825.           (logbitp 2 0 nil nil nil)
  1826.           (logcount 1 0 nil nil nil)
  1827.           (logeqv 0 0 t nil nil)
  1828.           (system::logical-pathname-p 1 0 nil nil nil)
  1829.           (logior 0 0 t nil nil)
  1830.           (lognand 2 0 nil nil nil)
  1831.           (lognor 2 0 nil nil nil)
  1832.           (lognot 1 0 nil nil nil)
  1833.           (logorc1 2 0 nil nil nil)
  1834.           (logorc2 2 0 nil nil nil)
  1835.           (logtest 2 0 nil nil nil)
  1836.           (logxor 0 0 t nil nil)
  1837.           (long-float-digits 0 0 nil nil nil)
  1838.           (system::long-float-p 1 0 nil nil nil)
  1839.           (lower-case-p 1 0 nil nil nil)
  1840.           (system::lpar-reader 2 0 nil nil nil)
  1841.           ;(machine-instance 0 0 nil nil nil)
  1842.           ;(machine-type 0 0 nil nil nil)
  1843.           ;(machine-version 0 0 nil nil nil)
  1844.           (macro-function 1 0 nil nil nil)
  1845.           (macroexpand 1 1 nil nil nil)
  1846.           (macroexpand-1 1 1 nil nil nil)
  1847.           (make-array 1 0 nil (:adjustable :element-type :initial-element :initial-contents :fill-pointer :displaced-to :displaced-index-offset) nil)
  1848.           (system::make-bit-vector 1 0 nil nil nil)
  1849.           (make-broadcast-stream 0 0 t nil nil)
  1850.           (make-buffered-input-stream 2 0 nil nil nil)
  1851.           (make-buffered-output-stream 1 0 nil nil nil)
  1852.           (make-char 1 2 nil nil nil)
  1853.           (system::make-code-vector 1 0 nil nil nil)
  1854.           (make-concatenated-stream 0 0 t nil nil)
  1855.           (make-dir 1 0 nil nil nil)
  1856.           (make-dispatch-macro-character 1 2 nil nil nil)
  1857.           (make-echo-stream 2 0 nil nil nil)
  1858.           (make-hash-table 0 0 nil (:initial-contents :test :size :rehash-size :rehash-threshold) nil)
  1859.           (make-list 1 0 nil (:initial-element) nil)
  1860.           (system::make-load-time-eval 1 0 nil nil nil)
  1861.           (make-package 1 0 nil (:nicknames :use) nil)
  1862.           (make-pathname 0 0 nil (:defaults :case :host :device :directory :name :type :version) nil)
  1863.           #+(or UNIX OS/2) (make-pipe-input-stream 1 0 nil nil nil)
  1864.           #+(or UNIX OS/2) (make-pipe-output-stream 1 0 nil nil nil)
  1865.           (make-random-state 0 1 nil nil nil)
  1866.           (make-sequence 2 0 nil (:initial-element :update) nil)
  1867.           (make-string 1 0 nil (:initial-element) nil)
  1868.           (make-string-input-stream 1 2 nil nil nil)
  1869.           (make-string-output-stream 0 1 nil nil nil)
  1870.           (system::make-string-push-stream 1 0 nil nil nil)
  1871.           (make-symbol 1 0 nil nil nil)
  1872.           (make-synonym-stream 1 0 nil nil nil)
  1873.           (make-two-way-stream 2 0 nil nil nil)
  1874.           (makunbound 1 0 nil nil nil)
  1875.           (map 3 0 t nil nil)
  1876.           (system::map-all-symbols 1 0 nil nil nil)
  1877.           (system::map-external-symbols 2 0 nil nil nil)
  1878.           (system::map-symbols 2 0 nil nil nil)
  1879.           (mapc 2 0 t nil nil)
  1880.           (mapcan 2 0 t nil nil)
  1881.           (mapcar 2 0 t nil nil)
  1882.           (mapcon 2 0 t nil nil)
  1883.           (maphash 2 0 nil nil nil)
  1884.           (mapl 2 0 t nil nil)
  1885.           (maplist 2 0 t nil nil)
  1886.           (mask-field 2 0 nil nil nil)
  1887.           (max 1 0 t nil nil)
  1888.           (member 2 0 nil (:test :test-not :key) nil)
  1889.           (member-if 2 0 nil (:key) nil)
  1890.           (member-if-not 2 0 nil (:key) nil)
  1891.           (merge 4 0 nil (:key) nil)
  1892.           (merge-pathnames 1 2 nil (:wild) nil)
  1893.           (min 1 0 t nil nil)
  1894.           (minusp 1 0 nil nil nil)
  1895.           (mismatch 2 0 nil (:from-end :start1 :end1 :start2 :end2 :key :test :test-not) nil)
  1896.           (mod 2 0 nil nil nil)
  1897.           (name-char 1 0 nil nil nil)
  1898.           (namestring 1 1 nil nil nil)
  1899.           (nbutlast 1 1 nil nil nil)
  1900.           (nconc 0 0 t nil nil)
  1901.           (ninth 1 0 nil nil nil)
  1902.           (not 1 0 nil nil nil)
  1903.           (system::not-feature-reader 3 0 nil nil nil)
  1904.           (system::not-readable-reader 3 0 nil nil nil)
  1905.           (notany 2 0 t nil nil)
  1906.           (notevery 2 0 t nil nil)
  1907.           (nreconc 2 0 nil nil nil)
  1908.           (nreverse 1 0 nil nil nil)
  1909.           (nstring-capitalize 1 0 nil (:start :end) nil)
  1910.           (nstring-downcase 1 0 nil (:start :end) nil)
  1911.           (nstring-upcase 1 0 nil (:start :end) nil)
  1912.           (nsublis 2 0 nil (:test :test-not :key) nil)
  1913.           (nsubst 3 0 nil (:test :test-not :key) nil)
  1914.           (nsubst-if 3 0 nil (:key) nil)
  1915.           (nsubst-if-not 3 0 nil (:key) nil)
  1916.           (nsubstitute 3 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  1917.           (nsubstitute-if 3 0 nil (:from-end :start :end :key :count) nil)
  1918.           (nsubstitute-if-not 3 0 nil (:from-end :start :end :key :count) nil)
  1919.           (nth 2 0 nil nil nil)
  1920.           (nthcdr 2 0 nil nil nil)
  1921.           (null 1 0 nil nil nil)
  1922.           (numberp 1 0 nil nil nil)
  1923.           (numerator 1 0 nil nil nil)
  1924.           (system::octal-reader 3 0 nil nil nil)
  1925.           (oddp 1 0 nil nil nil)
  1926.           (open 1 0 nil (:direction :element-type :if-exists :if-does-not-exist) nil)
  1927.           (output-stream-p 1 0 nil nil nil)
  1928.           (package-name 1 0 nil nil nil)
  1929.           (package-nicknames 1 0 nil nil nil)
  1930.           (package-shadowing-symbols 1 0 nil nil nil)
  1931.           (package-use-list 1 0 nil nil nil)
  1932.           (package-used-by-list 1 0 nil nil nil)
  1933.           (packagep 1 0 nil nil nil)
  1934.           (pairlis 2 1 nil nil nil)
  1935.           (system::parse-body 1 2 nil nil nil)
  1936.           (parse-integer 1 0 nil (:start :end :radix :junk-allowed) nil)
  1937.           (parse-namestring 1 2 nil (:start :end :junk-allowed) nil)
  1938.           (pathname 1 0 nil nil nil)
  1939.           (pathname-device 1 0 nil (:case) nil)
  1940.           (pathname-directory 1 0 nil (:case) nil)
  1941.           (pathname-host 1 0 nil (:case) nil)
  1942.           (pathname-match-p 2 0 nil nil nil)
  1943.           (pathname-name 1 0 nil (:case) nil)
  1944.           (system::pathname-reader 3 0 nil nil nil)
  1945.           (pathname-type 1 0 nil (:case) nil)
  1946.           (pathname-version 1 0 nil nil nil)
  1947.           (pathnamep 1 0 nil nil nil)
  1948.           (peek-char 0 5 nil nil nil)
  1949.           (phase 1 0 nil nil nil)
  1950.           (plusp 1 0 nil nil nil)
  1951.           (position 2 0 nil (:from-end :start :end :key :test :test-not) nil)
  1952.           (position-if 2 0 nil (:from-end :start :end :key) nil)
  1953.           (position-if-not 2 0 nil (:from-end :start :end :key) nil)
  1954.           (pprint 1 1 nil nil nil)
  1955.           (prin1 1 1 nil nil nil)
  1956.           (prin1-to-string 1 0 nil nil nil)
  1957.           (princ 1 1 nil nil nil)
  1958.           (princ-to-string 1 0 nil nil nil)
  1959.           (print 1 1 nil nil nil)
  1960.           (probe-file 1 0 nil nil nil)
  1961.           (proclaim 1 0 nil nil nil)
  1962.           (system::puthash 3 0 nil nil nil)
  1963.           (system::quote-reader 2 0 nil nil nil)
  1964.           (system::radix-reader 3 0 nil nil nil)
  1965.           (random 1 1 nil nil nil)
  1966.           (random-state-p 1 0 nil nil nil)
  1967.           (rassoc 2 0 nil (:test :test-not :key) nil)
  1968.           (rassoc-if 2 0 nil (:key) nil)
  1969.           (rassoc-if-not 2 0 nil (:key) nil)
  1970.           (rational 1 0 nil nil nil)
  1971.           (rationalize 1 0 nil nil nil)
  1972.           (rationalp 1 0 nil nil nil)
  1973.           (read 0 4 nil nil nil)
  1974.           (read-byte 1 2 nil nil nil)
  1975.           (read-char 0 4 nil nil nil)
  1976.           (read-char-no-hang 0 4 nil nil nil)
  1977.           (read-delimited-list 1 2 nil nil nil)
  1978.           (system::read-eval-print 1 1 nil nil nil)
  1979.           (system::read-eval-reader 3 0 nil nil nil)
  1980.           (system::read-form 1 1 nil nil nil)
  1981.           (read-from-string 1 2 nil (:preserve-whitespace :start :end) nil)
  1982.           (read-line 0 4 nil nil nil)
  1983.           (read-preserving-whitespace 0 4 nil nil nil)
  1984.           (readtablep 1 0 nil nil nil)
  1985.           (realp 1 0 nil nil nil)
  1986.           (realpart 1 0 nil nil nil)
  1987.           (system::redo-eval-frame 1 0 nil nil nil)
  1988.           (reduce 2 0 nil (:from-end :start :end :key :initial-value) nil)
  1989.           (rem 2 0 nil nil nil)
  1990.           (remhash 2 0 nil nil nil)
  1991.           (remove 2 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  1992.           (remove-duplicates 1 0 nil (:from-end :start :end :key :test :test-not) nil)
  1993.           (remove-if 2 0 nil (:from-end :start :end :key :count) nil)
  1994.           (remove-if-not 2 0 nil (:from-end :start :end :key :count) nil)
  1995.           (remprop 2 0 nil nil nil)
  1996.           (rename-file 2 0 nil nil nil)
  1997.           (rename-package 2 1 nil nil nil)
  1998.           (replace 2 0 nil (:start1 :end1 :start2 :end2) nil)
  1999.           (rest 1 0 nil nil nil)
  2000.           (system::return-from-eval-frame 2 0 nil nil nil)
  2001.           (revappend 2 0 nil nil nil)
  2002.           (reverse 1 0 nil nil nil)
  2003.           (room 0 0 nil nil nil)
  2004.           (round 1 1 nil nil nil)
  2005.           (row-major-aref 2 0 nil nil nil)
  2006.           (system::row-major-store 3 0 nil nil nil)
  2007.           (system::rpar-reader 2 0 nil nil nil)
  2008.           (rplaca 2 0 nil nil nil)
  2009.           (rplacd 2 0 nil nil nil)
  2010.           (system::same-env-as 2 0 nil nil nil)
  2011.           (savemem 1 0 nil nil nil)
  2012.           (sbit 1 0 t nil nil)
  2013.           (scale-float 2 0 nil nil nil)
  2014.           (schar 2 0 nil nil nil)
  2015.           (search 2 0 nil (:from-end :start1 :end1 :start2 :end2 :key :test :test-not) nil)
  2016.           (system::search-string-equal 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2017.           (system::search-string= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2018.           (second 1 0 nil nil nil)
  2019.           (system::sequencep 1 0 nil nil nil)
  2020.           (set 2 0 nil nil nil)
  2021.           (set-char-bit 3 0 nil nil nil)
  2022.           (set-dispatch-macro-character 3 1 nil nil nil)
  2023.           (system::set-fill-pointer 2 0 nil nil nil)
  2024.           (set-macro-character 2 2 nil nil nil)
  2025.           (set-syntax-from-char 2 2 nil nil nil)
  2026.           (seventh 1 0 nil nil nil)
  2027.           (shadow 1 1 nil nil nil)
  2028.           (shadowing-import 1 1 nil nil nil)
  2029.           ;(shell 0 1 nil nil nil)
  2030.           (system::short-float-p 1 0 nil nil nil)
  2031.           (show-stack 0 0 nil nil nil)
  2032.           (signum 1 0 nil nil nil)
  2033.           (system::simple-array-p 1 0 nil nil nil)
  2034.           (simple-bit-vector-p 1 0 nil nil nil)
  2035.           (simple-string-p 1 0 nil nil nil)
  2036.           (simple-vector-p 1 0 nil nil nil)
  2037.           (sin 1 0 nil nil nil)
  2038.           (system::single-float-p 1 0 nil nil nil)
  2039.           (sinh 1 0 nil nil nil)
  2040.           (sixth 1 0 nil nil nil)
  2041.           (clos:slot-value 2 0 nil nil nil)
  2042.           (clos::set-slot-value 3 0 nil nil nil)
  2043.           (clos:slot-boundp 2 0 nil nil nil)
  2044.           (clos:slot-makunbound 2 0 nil nil nil)
  2045.           (clos:slot-exists-p 2 0 nil nil nil)
  2046.           (software-type 0 0 nil nil nil)
  2047.           (software-version 0 0 nil nil nil)
  2048.           (some 2 0 t nil nil)
  2049.           (sort 2 0 nil (:key :start :end) nil)
  2050.           (special-form-p 1 0 nil nil nil)
  2051.           (system::special-variable-p 1 0 nil nil nil)
  2052.           (sqrt 1 0 nil nil nil)
  2053.           (stable-sort 2 0 nil (:key :start :end) nil)
  2054.           (standard-char-p 1 0 nil nil nil)
  2055.           (clos::std-instance-p 1 0 nil nil nil)
  2056.           (system::store 2 0 t nil nil)
  2057.           (system::store-char 3 0 nil nil nil)
  2058.           (system::store-schar 3 0 nil nil nil)
  2059.           (stream-element-type 1 0 nil nil nil)
  2060.           (streamp 1 0 nil nil nil)
  2061.           (string 1 0 nil nil nil)
  2062.           (system::string-both-trim 3 0 nil nil nil)
  2063.           (string-capitalize 1 0 nil (:start :end) nil)
  2064.           (string-char-p 1 0 nil nil nil)
  2065.           (string-concat 0 0 t nil nil)
  2066.           (string-downcase 1 0 nil (:start :end) nil)
  2067.           (string-equal 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2068.           (string-greaterp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2069.           (system::string-input-stream-index 1 0 nil nil nil)
  2070.           (string-lessp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2071.           (string-not-equal 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2072.           (string-not-greaterp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2073.           (string-not-lessp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2074.           (system::string-reader 2 0 nil nil nil)
  2075.           (system::string-stream-p 1 0 nil nil nil)
  2076.           (string-upcase 1 0 nil (:start :end) nil)
  2077.           (string/= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2078.           (string< 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2079.           (string<= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2080.           (string= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2081.           (string> 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2082.           (string>= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2083.           (stringp 1 0 nil nil nil)
  2084.           (clos::structure-instance-p 1 0 nil nil nil)
  2085.           (system::structure-reader 3 0 nil nil nil)
  2086.           (sublis 2 0 nil (:test :test-not :key) nil)
  2087.           (system::subr-info 1 0 nil nil nil)
  2088.           (subseq 2 1 nil nil nil)
  2089.           (subst 3 0 nil (:test :test-not :key) nil)
  2090.           (subst-if 3 0 nil (:key) nil)
  2091.           (subst-if-not 3 0 nil (:key) nil)
  2092.           (substitute 3 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  2093.           (substitute-if 3 0 nil (:from-end :start :end :key :count) nil)
  2094.           (substitute-if-not 3 0 nil (:from-end :start :end :key :count) nil)
  2095.           (substring 2 1 nil nil nil)
  2096.           (svref 2 0 nil nil nil)
  2097.           (system::svstore 3 0 nil nil nil)
  2098.           (sxhash 1 0 nil nil nil)
  2099.           (symbol-function 1 0 nil nil nil)
  2100.           (symbol-name 1 0 nil nil nil)
  2101.           (symbol-package 1 0 nil nil nil)
  2102.           (symbol-plist 1 0 nil nil nil)
  2103.           (symbol-value 1 0 nil nil nil)
  2104.           (symbolp 1 0 nil nil nil)
  2105.           (system::synonym-stream-p 1 0 nil nil nil)
  2106.           (system::syntax-error-reader 3 0 nil nil nil)
  2107.           (tailp 2 0 nil nil nil)
  2108.           (tan 1 0 nil nil nil)
  2109.           (tanh 1 0 nil nil nil)
  2110.           (tenth 1 0 nil nil nil)
  2111.           (terpri 0 1 nil nil nil)
  2112.           (system::the-frame 0 0 nil nil nil)
  2113.           (third 1 0 nil nil nil)
  2114.           (translate-pathname 3 0 nil (:all :merge) nil)
  2115.           (tree-equal 2 0 nil (:test :test-not) nil)
  2116.           (truename 1 0 nil nil nil)
  2117.           (truncate 1 1 nil nil nil)
  2118.           (system::two-way-stream-p 1 0 nil nil nil)
  2119.           (type-of 1 0 nil nil nil)
  2120.           (unexport 1 1 nil nil nil)
  2121.           (unintern 1 1 nil nil nil)
  2122.           (system::uninterned-reader 3 0 nil nil nil)
  2123.           (unread-char 1 1 nil nil nil)
  2124.           (unuse-package 1 1 nil nil nil)
  2125.           (system::unwind-to-driver 0 0 nil nil nil)
  2126.           (upper-case-p 1 0 nil nil nil)
  2127.           (use-package 1 1 nil nil nil)
  2128.           (system::use-package-aux 1 0 nil nil nil)
  2129.           #+UNIX (user-homedir-pathname 0 1 nil nil nil)
  2130.           (values 0 0 t nil nil)
  2131.           (values-list 1 0 nil nil nil)
  2132.           (vector 0 0 t nil nil)
  2133.           (system::vector-endtest 2 0 nil nil nil)
  2134.           (system::vector-fe-endtest 2 0 nil nil nil)
  2135.           (system::vector-fe-init 1 0 nil nil nil)
  2136.           (system::vector-fe-init-end 2 0 nil nil nil)
  2137.           (system::vector-fe-upd 2 0 nil nil nil)
  2138.           (system::vector-init 1 0 nil nil nil)
  2139.           (system::vector-init-start 2 0 nil nil nil)
  2140.           (system::vector-length 1 0 nil nil nil)
  2141.           (vector-pop 1 0 nil nil nil)
  2142.           (vector-push 2 0 nil nil nil)
  2143.           (vector-push-extend 2 1 nil nil nil)
  2144.           (system::vector-reader 3 0 nil nil nil)
  2145.           (system::vector-upd 2 0 nil nil nil)
  2146.           (vectorp 1 0 nil nil nil)
  2147.           (system::version 0 1 nil nil nil)
  2148.           (wild-pathname-p 1 1 nil nil nil)
  2149.           (write 1 0 nil (:case :level :length :gensym :escape :radix :base :array :circle :pretty :closure :readably :stream) nil)
  2150.           (write-byte 2 0 nil nil nil)
  2151.           (write-char 1 1 nil nil nil)
  2152.           (write-line 1 1 nil (:start :end) nil)
  2153.           (write-string 1 1 nil (:start :end) nil)
  2154.           (write-to-string 1 0 nil (:case :level :length :gensym :escape :radix :base :array :circle :pretty :closure :readably) nil)
  2155.           (xgcd 0 0 t nil nil)
  2156.           (zerop 1 0 nil nil nil)
  2157. ) ) ) )  )
  2158. (defconstant function-codes
  2159.   (let ((hashtable (make-hash-table :test #'eq)))
  2160.     (dotimes (i (* 3 256))
  2161.       (let ((sym (%funtabref i))) ; Name der Funktion FUNTAB[i]
  2162.         (when sym (setf (gethash sym hashtable) i))
  2163.     ) )
  2164.     hashtable
  2165. ) )
  2166. (defconstant funtabR-index ; Startindex der FUNTABR bzgl. FUNTAB
  2167.   (dotimes (i (* 3 256))
  2168.     (let ((sym (%funtabref i)))
  2169.       (multiple-value-bind (name req opt rest-p) (subr-info sym)
  2170.         (declare (ignore name req opt))
  2171.         (when rest-p (return i))
  2172. ) ) ) )
  2173. (defun CALLS-code (funtab-index)
  2174.   (if (< funtab-index 256)
  2175.     `(CALLS1 ,funtab-index)
  2176.     `(CALLS2 ,(- funtab-index 256))
  2177. ) )
  2178.  
  2179. ; Hilfsfunktion: mapcan, aber mit append statt nconc:
  2180. #|
  2181. #-CLISP
  2182. (defun mapcap (fun &rest lists &aux (L nil))
  2183.   (loop
  2184.     (setq L
  2185.       (nconc
  2186.         (reverse
  2187.           (apply fun
  2188.             (maplist #'(lambda (listsr)
  2189.                          (if (atom (car listsr))
  2190.                            (return)
  2191.                            (pop (car listsr))
  2192.                        ) )
  2193.                      lists
  2194.         ) ) )
  2195.         L
  2196.       )
  2197.   ) )
  2198.   (nreverse L)
  2199. )
  2200. |#
  2201. #-CLISP
  2202. (defun mapcap (fun &rest lists)
  2203.   (apply #'append (apply #'mapcar fun lists))
  2204. )
  2205.  
  2206. ; Hilfsfunktion: mapcon, aber mit append statt nconc:
  2207. #|
  2208. #-CLISP
  2209. (defun maplap (fun &rest lists &aux (L nil))
  2210.   (loop
  2211.     (setq L
  2212.       (nconc
  2213.         (reverse
  2214.           (apply fun
  2215.             (maplist #'(lambda (listsr)
  2216.                          (if (atom (car listsr))
  2217.                            (return)
  2218.                            (prog1
  2219.                              (car listsr)
  2220.                              (setf (car listsr) (cdr (car listsr)))
  2221.                        ) ) )
  2222.                      lists
  2223.         ) ) )
  2224.         L
  2225.       )
  2226.   ) )
  2227.   (nreverse L)
  2228. )
  2229. |#
  2230. #-CLISP
  2231. (defun maplap (fun &rest lists)
  2232.   (apply #'append (apply #'maplist fun lists))
  2233. )
  2234.  
  2235. ; (memq item const-symbollist) == (member item const-symbollist :test #'eq),
  2236. ; nur der boolesche Wert.
  2237. (defmacro memq (item list)
  2238.   (if (and (constantp list) (listp (eval list)))
  2239.     `(case ,item (,(eval list) t) (t nil))
  2240.     `(member ,item ,list :test #'eq)
  2241. ) )
  2242.  
  2243. ; Fehlermeldungsfunktion
  2244. (defun compiler-error (caller &optional where)
  2245.   (error (DEUTSCH "Fehler im Compiler!! Aufgetreten in ~A~@[ bei ~A~]."
  2246.           ENGLISH "Compiler bug!! Occurred in ~A~@[ at ~A~]."
  2247.           FRANCAIS "Erreur dans le compilateur!! ArrivΘ dans ~A~@[ au point ~A~].")
  2248.          caller where
  2249. ) )
  2250.  
  2251.  
  2252.  
  2253. ;                      S T A C K - V E R W A L T U N G
  2254.  
  2255. ; Ein Stackzustand beschreibt, was sich zur Laufzeit alles auf den beiden
  2256. ; Stacks befinden wird.
  2257. ; Genaue Struktur:
  2258. ; (item1 ... itemk . fun)
  2259. ; Das ist im Speicher in Wirklichkeit eine Baumstruktur!
  2260. ; Es bedeuten hierbei:
  2261. ;  fun = FNODE der Funktion, in der gezΣhlt wird.
  2262. ;  item = eines der folgenden:
  2263. ;    n (Integer >=0) : n Lisp-Objekte auf dem STACK
  2264. ;                      belegt n STACK-EintrΣge
  2265. ;    (BIND n)        : einen Bindungsframe fⁿr n Variablen,
  2266. ;                      belegt 1+2*n STACK-EintrΣge und 0 SP-EintrΣge
  2267. ;                      Mu▀ bei Unwind explizit aufgel÷st werden
  2268. ;    PROGV           : ein Bindungsframe fⁿr beliebig viele Variablen,
  2269. ;                      belegt ? STACK-EintrΣge und 1 SP-Eintrag (Pointer ⁿber
  2270. ;                      den Frame = alter STACK)
  2271. ;                      Mu▀ bei Unwind explizit aufgel÷st werden
  2272. ;    CATCH           : ein CATCH-Frame
  2273. ;                      belegt 3 STACK-EintrΣge und 2+jmpbufsize SP-EintrΣge
  2274. ;    UNWIND-PROTECT  : ein Unwind-Protect-Frame
  2275. ;                      belegt 2 STACK-EintrΣge und 2+jmpbufsize SP-EintrΣge
  2276. ;                      Mu▀ bei Unwind aufgel÷st und der Cleanup ausgefⁿhrt
  2277. ;                      werden
  2278. ;    CLEANUP         : wΣhrend der Cleanup-Phase eines UNWIND-PROTECT
  2279. ;                      belegt ? STACK-EintrΣge und 3 SP-EintrΣge
  2280. ;                      (der untere ist Pointer ⁿber den Frame = alter STACK)
  2281. ;    BLOCK           : ein BLOCK-Frame
  2282. ;                      belegt 3 STACK-EintrΣge und 2+jmpbufsize SP-EintrΣge
  2283. ;                      Mu▀ bei Unwind explizit aufgel÷st werden
  2284. ;    (TAGBODY n)     : ein TAGBODY-Frame, der n Tags aufhebt
  2285. ;                      belegt 3+n STACK-EintrΣge und 1+jmpbufsize SP-EintrΣge
  2286. ;                      Mu▀ bei Unwind explizit aufgel÷st werden
  2287. ;    MVCALLP         : Vorbereitung fⁿr MVCALL
  2288. ;                      belegt 1 STACK-Eintrag und 1 SP-Eintrag (Pointer ⁿber
  2289. ;                      FRAME = STACK)
  2290. ;    MVCALL          : viele Lisp-Objekte
  2291. ;                      belegt ? STACK-EintrΣge und 1 SP-Eintrag (Pointer ⁿber
  2292. ;                      Frame = alter STACK)
  2293. ;    ANYTHING        : viele Lisp-Objekte und Frames
  2294. ;                      belegt ? STACK-EintrΣge und 1 SP-Eintrag (Pointer ⁿber
  2295. ;                      Frame = alter STACK)
  2296.  
  2297. (defvar *stackz*)    ; der aktuelle Stackzustand
  2298.  
  2299. ; Eine SP-Tiefe k ist ein Cons (k1 . k2) und bedeutet k1+jmpbufsize*k2.
  2300. (defmacro spd (k1 k2) `(cons ,k1 ,k2))
  2301. (defun spd+ (k kd)
  2302.   (cons (+ (car k) (car kd))
  2303.         (+ (cdr k) (cdr kd))
  2304. ) )
  2305. (defun spd- (k kd)
  2306.   (cons (- (car k) (car kd))
  2307.         (- (cdr k) (cdr kd))
  2308. ) )
  2309. (defun spd<= (k kk)
  2310.   (and (<= (car k) (car kk))
  2311.        (<= (cdr k) (cdr kk))
  2312. ) )
  2313. ; We cannot simply take the maximum of two depths, have to work with lists.
  2314. ; Is depth covered by some of the depths in the list?
  2315. (defun some-spd<= (depth list-of-depths)
  2316.   (dolist (x list-of-depths nil)
  2317.     (when (spd<= depth x) (return t))
  2318. ) )
  2319.  
  2320. ; (stackz-fun stackz) extrahiert aus einem Stackzustand die Funktion, in der
  2321. ; gerade gearbeitet wird.
  2322. #|
  2323. (defun stackz-fun (stackz)
  2324.   (loop (when (atom stackz) (return)) (setq stackz (cdr stackz)))
  2325.   stackz
  2326. )
  2327. |#
  2328. ; Σquivalent, aber schneller:
  2329. (defun stackz-fun (stackz)
  2330.   (if (atom stackz) stackz (cdr (last stackz)))
  2331. )
  2332.  
  2333. ; (in-same-function-p stackz1 stackz2) stellt fest, ob in beiden StackzustΣnden
  2334. ; in derselben Funktion gearbeitet wird.
  2335. (defun in-same-function-p (stackz1 stackz2)
  2336.   (eq (stackz-fun stackz1) (stackz-fun stackz2))
  2337. )
  2338.  
  2339. ; (zugriff-in-stack stackz1 stackz2)
  2340. ; Fⁿr den Zugriff auf lokale Variablen im Stack:
  2341. ; ergibt zu zwei StackzustΣnden stackz1 und stackz2, die beide innerhalb
  2342. ; derselben Funktion liegen und wo stackz1 "tiefer" ist als stackz2:
  2343. ; 2 Werte: NIL und n, falls (stackz2) = (STACK+4*n) von stackz1 aus,
  2344. ;          k und n, falls (stackz2) = ((SP+4*k)+4*n) von stackz1 aus.
  2345. ; (Falls stackz2 mit BLOCK oder TAGBODY beginnt, ist immer der Zugriff auf die
  2346. ;  consvar eines Block- bzw. Tagbody-Frames gemeint.)
  2347. (defun zugriff-in-stack (stackz1 stackz2 &aux (k nil) (n 0) (kd (spd 0 0)))
  2348.   (loop ; beim Durchlaufen der Stacks nach oben:
  2349.     ; momentanes STACK ist STACK+4*n (bei k=NIL) bzw. (SP+4*k)+4*n,
  2350.     ; momentanes SP ist SP+4*kd (bei k=NIL) bzw. SP+4*(k+kd).
  2351.     (when (eq stackz1 stackz2) (return))
  2352.     (when (atom stackz1) (compiler-error 'zugriff-in-stack "STACKZ-END"))
  2353.     (let ((item (car stackz1)))
  2354.       (cond ((integerp item) (setq n (+ n item)))
  2355.             ((consp item)
  2356.              (case (first item)
  2357.                (BIND    (setq n (+ n (+ 1 (* 2 (second item))))))
  2358.                (TAGBODY (setq kd (spd+ kd (spd 1 1))
  2359.                               n (+ n (+ 3 (second item)))
  2360.                )        )
  2361.                (t (compiler-error 'zugriff-in-stack "STACKZ-LISTITEM"))
  2362.             ))
  2363.             (t
  2364.              (case item
  2365.                (PROGV          (setq k (if k (spd+ k kd) kd) kd (spd 1 0) n 0))
  2366.                (CATCH          (setq kd (spd+ kd (spd 2 1)) n (+ n 3)))
  2367.                (UNWIND-PROTECT (setq kd (spd+ kd (spd 2 1)) n (+ n 2)))
  2368.                (CLEANUP        (setq k (if k (spd+ k kd) kd) kd (spd 3 0) n 0))
  2369.                (BLOCK          (setq kd (spd+ kd (spd 2 1)) n (+ n 3)))
  2370.                (MVCALLP        (setq kd (spd+ kd (spd 1 0)) n (+ n 1)))
  2371.                ((MVCALL ANYTHING)
  2372.                                (setq k (if k (spd+ k kd) kd) kd (spd 1 0) n 0))
  2373.                (t (compiler-error 'zugriff-in-stack "STACKZ-ITEM"))
  2374.     ) )     ))
  2375.     (setq stackz1 (cdr stackz1))
  2376.   )
  2377.   (when (and (consp stackz2) ; beim Zugriff auf BLOCK- bzw. TAGBODY-consvar:
  2378.              (or (eq (car stackz2) 'BLOCK)
  2379.                  (and (consp (car stackz2)) (eq (first (car stackz2)) 'TAGBODY))
  2380.         )    )
  2381.     (setq n (+ n 2)) ; consvar liegt genau 2 EintrΣge h÷her als Frameanfang
  2382.   )
  2383.   (values k n)
  2384. )
  2385.  
  2386. ; (may-UNWIND stackz1 stackz2)
  2387. ; stellt fest, ob (UNWIND stackz1 stackz2 for-value) legal ist. Dazu ist
  2388. ; notwendig, da▀ der Compiler ⁿber die Frames zwischen stackz1 und stackz2
  2389. ; genau Bescheid wei▀.
  2390. (defun may-UNWIND (stackz1 stackz2)
  2391.   (loop
  2392.     (when (eq stackz1 stackz2) (return t))
  2393.     (when (atom stackz1) (compiler-error 'may-UNWIND "STACKZ-END"))
  2394.     (when (eq (car stackz1) 'ANYTHING) (return nil))
  2395.     (setq stackz1 (cdr stackz1))
  2396. ) )
  2397.  
  2398. ; (expand-UNWIND stackz1 stackz2 for-value)
  2399. ; liefert ein zu (UNWIND stackz1 stackz2 for-value) Σquivalentes Codestⁿck,
  2400. ; bestehend aus
  2401. ; (SKIP n), (SKIPI k1 k2 n), (SKIPSP k1 k2), (VALUES0),
  2402. ; (UNWIND-PROTECT-CLEANUP), (UNBIND1), (BLOCK-CLOSE), (TAGBODY-CLOSE).
  2403. ; Es mu▀ - ausgehend von stackz1 - den Stack so bereinigen, da▀ danach der
  2404. ; Stackzustand stackz2 vorliegt. Bei for-value=NIL k÷nnen die Werte dabei
  2405. ; weggeworfen werden.
  2406. (defun expand-UNWIND (stackz1 stackz2 for-value
  2407.                       &aux (k nil) (n 0) (kd (spd 0 0)) (codelist nil))
  2408.   (flet ((here () ; bis hierher erst einmal die Stacks hochsetzen
  2409.            (if k
  2410.              (progn
  2411.                (push `(SKIPI ,(car k) ,(cdr k) ,n) codelist)
  2412.                (unless (> (car kd) 0) (compiler-error 'expand-UNWIND "SP-depth"))
  2413.                (when (or (> (car kd) 1) (> (cdr kd) 0))
  2414.                  (push `(SKIPSP ,(- (car kd) 1) ,(cdr kd)) codelist)
  2415.              ) )
  2416.              (progn
  2417.                (when (> n 0) (push `(SKIP ,n) codelist))
  2418.                (when (or (> (car kd) 0) (> (cdr kd) 0))
  2419.                  (push `(SKIPSP ,(car kd) ,(cdr kd)) codelist)
  2420.            ) ) )
  2421.            (setq k nil n 0 kd (spd 0 0))
  2422.         ))
  2423.     (loop ; beim Durchlaufen der Stacks nach oben:
  2424.       ; momentanes STACK ist STACK+4*n (bei k=NIL) bzw. (SP+4*k)+4*n,
  2425.       ; momentanes SP ist SP+4*kd (bei k=NIL) bzw. SP+4*(k+kd).
  2426.       (when (eq stackz1 stackz2) (here) (return))
  2427.       (when (atom stackz1) (compiler-error 'expand-UNWIND "STACKZ-END"))
  2428.       (let ((item (car stackz1)))
  2429.         (cond ((integerp item) (setq n (+ n item)))
  2430.               ((consp item)
  2431.                (case (first item)
  2432.                  (BIND    (here) (push '(UNBIND1) codelist))
  2433.                  (TAGBODY (here) (push '(TAGBODY-CLOSE) codelist))
  2434.                  (t (compiler-error 'expand-UNWIND "STACKZ-LISTITEM"))
  2435.               ))
  2436.               (t
  2437.                (case item
  2438.                  (PROGV (here) (push '(UNBIND1) codelist) (setq kd (spd 1 0)))
  2439.                  (CATCH (setq kd (spd+ kd (spd 2 1)) n (+ n 3)))
  2440.                  (UNWIND-PROTECT
  2441.                    (here)
  2442.                    (unless for-value
  2443.                       ; bei for-value=NIL wird beim ersten auftretenden
  2444.                       ; UNWIND-PROTECT-Frame ein '(VALUES0) eingefⁿgt.
  2445.                      (setq for-value t)
  2446.                      (push '(VALUES0) codelist)
  2447.                    )
  2448.                    (push '(UNWIND-PROTECT-CLEANUP) codelist)
  2449.                  )
  2450.                  (CLEANUP (setq k (if k (spd+ k kd) kd) kd (spd 3 0) n 0))
  2451.                  (BLOCK (here) (push '(BLOCK-CLOSE) codelist))
  2452.                  (MVCALLP (setq kd (spd+ kd (spd 1 0)) n (+ n 1)))
  2453.                  (MVCALL (setq k (if k (spd+ k kd) kd) kd (spd 1 0) n 0))
  2454.                  (t (compiler-error 'expand-UNWIND "STACKZ-ITEM"))
  2455.       ) )     ))
  2456.       (setq stackz1 (cdr stackz1))
  2457.     )
  2458.     (nreverse codelist)
  2459. ) )
  2460.  
  2461. ; (spdepth-difference stackz1 stackz2)
  2462. ; liefert den Unterschied k von SP bei stackz1 und SP bei stackz2.
  2463. ; Um den SP von stackz1 zu stackz2 hochzusetzen, reicht also ein (SKIPSP k1 k2).
  2464. (defun spdepth-difference (stackz1 stackz2 &aux (k (spd 0 0)))
  2465.   (loop
  2466.     (when (eq stackz1 stackz2) (return))
  2467.     (when (atom stackz1) (compiler-error 'spdepth-difference "STACKZ-END"))
  2468.     (let ((item (car stackz1)))
  2469.       (if (consp item)
  2470.         (case (first item)
  2471.           (TAGBODY (setq k (spd+ k (spd 1 1))))
  2472.         )
  2473.         (case item
  2474.           ((PROGV MVCALLP MVCALL ANYTHING) (setq k (spd+ k (spd 1 0))))
  2475.           ((CATCH UNWIND-PROTECT BLOCK) (setq k (spd+ k (spd 2 1))))
  2476.           (CLEANUP (setq k (spd+ k (spd 3 0))))
  2477.     ) ) )
  2478.     (setq stackz1 (cdr stackz1))
  2479.   )
  2480.   k
  2481. )
  2482.  
  2483.  
  2484.  
  2485. ;        F U N C T I O N - E N V I R O N M E N T - V E R W A L T U N G
  2486.  
  2487. ; mitgegeben vom Interpreter: %fenv%
  2488.  
  2489. ; Interpreter-Funktions-Environment hat die Gestalt
  2490. ; %fenv% = NIL oder #(f1 def1 ... fn defn NEXT-ENV), NEXT-ENV von derselben
  2491. ; Gestalt.
  2492. ; Damit ist eine Abbildung fi --> defi realisiert.
  2493. ; defi = (SYSTEM::MACRO . expander)  bedeutet einen lokalen Macro.
  2494. ; defi = Closure                     bedeutet, da▀ defi die lokale
  2495. ;                                    Funktionsdefinition von fi ist
  2496. ; defi = NIL                         bedeutet, da▀ eine lokale Funktions-
  2497. ;                                    definition noch hineinkommt (vgl. LABELS)
  2498.  
  2499. ; neu konstruiert:
  2500. (defvar *fenv*)
  2501. ; enthΣlt die neuen lexikalischen Funktionsbindungen.
  2502. ; *fenv* hat dieselbe Gestalt wie %fenv% und endet mit %fenv%:
  2503. ; #(f1 def1 ... fn defn NEXT-ENV), was eine Abbildung fi --> defi
  2504. ; realisiert.
  2505. ; defi = (SYSTEM::MACRO expander)  bedeutet einen lokalen Makro.
  2506. ; defi = (fdescr . var)            bedeutet, da▀ die lokale Funktionsdefinition
  2507. ;           von fi zur Laufzeit in der lexikalischen Variablen var steckt.
  2508. ;           fnode ist der zu fi geh÷rige fnode, anfangs noch NIL.
  2509. ; defi = (fdescr . const)          bedeutet, da▀ die lokale Funktionsdefinition
  2510. ;           von fi autonom ist und in der Konstanten const steckt.
  2511. ;           fnode ist der zu fi geh÷rige fnode, anfangs noch NIL.
  2512. ; Dabei ist fdescr ein Cons (fnode . lambdadescr),
  2513. ;           fnode der zu fi geh÷rige fnode oder NIL,
  2514. ;           lambdadescr = (LABELS . Liste der Werte von analyze-lambdalist)
  2515. ;           oder lambdadescr = (GENERIC . Signature) oder NIL.
  2516.  
  2517. ; Suche die lokale Funktionsdefinition des Symbols f in fenv :
  2518. ; Ergebnis ist:
  2519. ; SYSTEM::MACRO, expander           bei einem lokalen Macro,
  2520. ; GLOBAL, Vektor, Index             wenn defi = (svref Vektor Index)
  2521. ;                                   (also in %fenv% gefunden)
  2522. ; LOCAL, def, fdescr                wenn defi = def eine Variable oder Konstante
  2523. ;                                   (also in *fenv* ohne %fenv% gefunden)
  2524. ; NIL                               falls nicht lokal definiert.
  2525. (defun fenv-search (f &optional (fenv *fenv*))
  2526.   (loop
  2527.     (when (null fenv) (return-from fenv-search 'NIL))
  2528.     (unless (simple-vector-p fenv) (compiler-error 'fenv-search))
  2529.     (do ((l (1- (length fenv)))
  2530.          (i 0 (+ i 2)))
  2531.         ((= i l) (setq fenv (svref fenv i)))
  2532.       (if (equal f (svref fenv i))
  2533.         (let ((def (svref fenv (1+ i))))
  2534.           (return-from fenv-search
  2535.             (if (consp def)
  2536.               (if (eq (car def) 'SYSTEM::MACRO)
  2537.                 (values 'SYSTEM::MACRO (cdr def))
  2538.                 (values 'LOCAL (cdr def) (car def))
  2539.               )
  2540.               (values 'GLOBAL fenv (1+ i))
  2541.   ) ) ) ) ) )
  2542. )
  2543. ; Stellt fest, ob ein Funktionsname im Function-Environment fenv nicht
  2544. ; definiert ist und daher auf die globale Funktion verweist.
  2545. (defun global-in-fenv-p (s fenv)
  2546.   (eq (fenv-search s fenv) 'NIL)
  2547. )
  2548.  
  2549. ; Mit einem Vektor aus
  2550. ; - einem solchen Variablen-Environment (verkettete Vektoren, mit
  2551. ;   defi = #<SYMBOL-MACRO expansion> fⁿr Symbol-Macro-Definitionen),
  2552. ; - einem solchen Funktions-Environment (verkettete Vektoren, mit
  2553. ;   defi = (SYSTEM::MACRO . expander) fⁿr Macro-Definitionen zu fi)
  2554. ; arbeiten die Funktionen
  2555. ; MACROEXPAND-1, MACROEXPAND, PARSE-BODY:
  2556. #|
  2557. (MACROEXPAND-1 form env) expandiert die gegebene Form im Macroexpansions-
  2558. Environment env und liefert die 1 mal expandierte Form und T
  2559. (oder form und NIL, falls nicht expandierbar).
  2560.  
  2561. (MACROEXPAND form env) expandiert die gegebene Form im Macroexpansions-
  2562. Environment env und liefert die sooft wie m÷glich expandierte Form und T
  2563. (oder form und NIL, falls nicht expandierbar).
  2564.  
  2565. (PARSE-BODY body docstring-allowed env) analysiert den body und spaltet von
  2566. ihm die Deklarationen und den Docstring (falls erlaubt und vorhanden) ab.
  2567. 3 Werte: der ⁿbrige body-rest, eine Liste der vorgekommenen declspecs,
  2568. der Docstring (oder NIL).
  2569. |#
  2570.  
  2571.  
  2572. ;           B L O C K - E N V I R O N M E N T - V E R W A L T U N G
  2573.  
  2574. ; mitgegeben vom Interpreter: %benv%
  2575.  
  2576. ; Interpreter-Block-Environment hat die Gestalt
  2577. ; %benv% = ((name1 . status1) ... (namen . statusn))
  2578. ; wobei namei ein Symbol und statusi der Status dieses lexikalisch umfassenden
  2579. ; Blocks ist: #<DISABLED> falls der Block bereits verlassen wurde, sonst ein
  2580. ; Pointer in den Stack auf den zugeh÷rigen Block-Frame.
  2581.  
  2582. ; neu konstruiert:
  2583. (defvar *benv*)
  2584.  
  2585. ; *benv* hat die Gestalt
  2586. ; ((name1 . block1) ... (namen . blockn) . %benv%)
  2587. ; wobei blocki der Descriptor des Blocks mit Namen namei ist:
  2588. (defstruct (block (:copier nil))
  2589.   fnode                 ; Funktion, in der dieser Block definiert ist, ein FNODE
  2590.   label                 ; label, an dem dieser Block zu Ende ist
  2591.   stackz                ; Stackzustand nach dem Aufbau des Block-Frames
  2592.   consvar               ; Variable, die im Stack im Block-Frame liegt und den
  2593.                         ; Block-Cons enthΣlt (dessen CDR beim Verlassen des
  2594.                         ; Blockes auf #<DISABLED> gesetzt wird)
  2595.   used-far              ; Flag, gibt an, ob dieser Block aus einer anderen
  2596.                         ; Funktion heraus mit RETURN-FROM verlassen wird.
  2597.   for-value             ; gibt an, ob das gesamte Block-Konstrukt Werte
  2598.                         ; zurⁿckliefern soll.
  2599. )
  2600. #+CLISP (remprop 'block 'sys::defstruct-description)
  2601.  
  2602. ; Sucht nach einem Block mit dem Namen name und liefert:
  2603. ; NIL                          falls nicht gefunden,
  2604. ; Block-Descriptor             falls in *benv* gefunden,
  2605. ; Block-Cons (name . status)   falls in %benv% gefunden.
  2606. (defun benv-search (name &optional (benv *benv*))
  2607.   (loop
  2608.     (when (atom benv) (return nil))
  2609.     (when (eq (caar benv) name)
  2610.       (if (block-p (cdar benv))
  2611.         (return (cdar benv))
  2612.         (return (car benv))
  2613.     ) )
  2614.     (setq benv (cdr benv))
  2615. ) )
  2616.  
  2617.  
  2618. ;         T A G B O D Y - E N V I R O N M E N T - V E R W A L T U N G
  2619.  
  2620. ; mitgegeben vom Interpreter: %genv%
  2621.  
  2622. ; Interpreter-Tagbody-Environment hat die Gestalt
  2623. ; %genv% = ((Tagvektor1 . status1) ... (Tagvektorn . statusn))
  2624. ; wobei Tagvektori ein simple-vector ist, der die anspringbaren Tags enthΣlt,
  2625. ; statusi der Status dieses lexikalisch umfassenden Tagbodys
  2626. ; ist: #<DISABLED> falls der Tagbody bereits verlassen wurde, sonst ein
  2627. ; Pointer in den Stack auf den zugeh÷rigen Tagbody-Frame.
  2628.  
  2629. ; neu konstruiert:
  2630. (defvar *genv*)
  2631.  
  2632. ; *genv* hat die Gestalt
  2633. ; ((Tagvektor1 . tagbody1) ... (Tagvektorn . tagbodyn) . %genv%)
  2634. ; wobei tagbodyi der Descriptor des Tagbodys i ist:
  2635. (defstruct (tagbody (:copier nil))
  2636.   fnode               ; Funktion, in der dieser Tagbody definiert ist, ein FNODE
  2637.   labellist           ; Liste der Labels, parallel zum Tagvektor
  2638.   stackz              ; Stackzustand nach dem Aufbau des Tagbody-Frames
  2639.   consvar             ; Variable, die im Stack im Tagbody-Frame liegt und den
  2640.                       ; Tagbody-Cons enthΣlt (dessen CDR beim Verlassen des
  2641.                       ; Tagbodys auf #<DISABLED> gesetzt wird)
  2642.   used-far            ; Vektor mit Fill-Pointer, enthΣlt all die Tags, die
  2643.                       ; aus einer anderen Funktion heraus mit GO angesprungen
  2644.                       ; werden.
  2645. )
  2646. #+CLISP (remprop 'tagbody 'sys::defstruct-description)
  2647.  
  2648. ; Sucht nach einem Tag mit dem Namen name und liefert:
  2649. ; NIL                                         falls nicht gefunden,
  2650. ; Tagbody-Descriptor, Index                   falls in *genv* gefunden,
  2651. ; Tagbody-Cons (Tagvektor . status), Index    falls in %genv% gefunden.
  2652. (defun genv-search (name &optional (genv *genv*))
  2653.   (loop
  2654.     (when (atom genv) (return nil))
  2655.     (do* ((v (caar genv))
  2656.           (l (length v))
  2657.           (i 0 (1+ i)))
  2658.          ((= i l))
  2659.       (when (eql (svref v i) name)
  2660.         (return-from genv-search
  2661.           (values (if (tagbody-p (cdar genv)) (cdar genv) (car genv)) i)
  2662.     ) ) )
  2663.     (setq genv (cdr genv))
  2664. ) )
  2665.  
  2666.  
  2667. ;       V A R I A B L E N - E N V I R O N M E N T - V E R W A L T U N G
  2668.  
  2669. ; mitgegeben vom Interpreter: %venv%
  2670.  
  2671. ; Interpreter-Variablen-Environment hat die Gestalt
  2672. ; %venv% = NIL oder #(v1 val1 ... vn valn NEXT-ENV), NEXT-ENV von derselben
  2673. ; Gestalt.
  2674. (defparameter specdecl
  2675.   #+CLISP (eval
  2676.             '(let ((*evalhook*
  2677.                      #'(lambda (form env) (declare (ignore form))
  2678.                          (svref (svref env 0) 1)
  2679.                          ; Der Evalhook-Mechanismus ⁿbergibt das Environment.
  2680.                          ; (svref...0) davon ist das Variablen-Environment,
  2681.                          ; (svref...1) davon ist von der *evalhook*-Bindung
  2682.                          ; der assoziierte "Wert" #<SPECIAL REFERENCE>.
  2683.                   ))   )
  2684.                0
  2685.           )  )
  2686.   #-CLISP (cons nil nil)
  2687. )
  2688. ; stellt fest, ob das Symbol var eine Special-Variable darstellt
  2689. #+CLISP
  2690. (defun proclaimed-special-p (var)
  2691.   (or (sys::special-variable-p var)
  2692.       (not (null (member var *known-special-vars* :test #'eq)))
  2693. ) )
  2694. #-CLISP
  2695. (defun proclaimed-special-p (var)
  2696.   (or
  2697.     (eq var '*evalhook*)
  2698.     (eq var '*applyhook*)
  2699.     (eq var '*macroexpand-hook*)
  2700.     (let ((obj (cons nil nil)))
  2701.       (eval
  2702.         `(let ((,var ',obj))
  2703.            (and (boundp ',var) (eq (symbol-value ',var) ',obj))
  2704.     ) )  )
  2705.     (not (null (member var *known-special-vars* :test #'eq)))
  2706. ) )
  2707.  
  2708. ; neu konstruiert:
  2709. (defvar *venv*)                  ; Variablen-Environment, Feinstruktur
  2710. (defvar *venvc*)                 ; Variablen-Environment, Grobstruktur
  2711.  
  2712. ; *venv* hat dieselbe Gestalt wie %venv% und endet mit %venv%:
  2713. ; #(v1 var1 ... vn varn NEXT_ENV), wo vari Variablen-Konstrukte oder
  2714. ; Symbolmacros oder Interpreter-Werte sind und NEXT-ENV von derselben Gestalt.
  2715.  
  2716. ; *venvc* simuliert das Laufzeit-Variablen-Environment zur Laufzeit, soweit
  2717. ; es sich um Closure-Variablen handelt.
  2718. ; *venvc* hat die Gestalt
  2719. ; (item1 ... itemn)
  2720. ; jedes item ist
  2721. ;   NIL :            ein LET/LET*/MULTIPLE-VALUE-BIND/Funktionseintritt/
  2722. ;                    FLET/LABELS, der keine Closure aufmacht
  2723. ;   fnode :          eine neue Funktion
  2724. ;   ((var1 ... vark) . stackz) : durch ein LET/LET*/MULTIPLE-VALUE-BIND/
  2725. ;                    Funktionseintritt/FLET/LABELS kommen die Variablen
  2726. ;                    Var1, ..., Vark in eine Closure.
  2727. ;                    Diese Closure liegt im Stack; angegeben der
  2728. ;                    Stackzustand, an der sie erreichbar ist.
  2729.  
  2730. ; Eine Variable wird beschrieben dadurch, da▀ sie entweder special ist oder
  2731. ; - falls lexikalisch - der Stackaufbau nach dem Anlegen der Variablen im Stack
  2732. ; bzw. der Ort in der Closure festliegt.
  2733. (defstruct (var (:copier nil))
  2734.   (name nil :read-only t)     ; Symbol
  2735.   (specialp nil :read-only t) ; special deklariert (oder lexikalisch gebunden) ?
  2736.   constantp                   ; Konstante ?
  2737.   constant                    ; wenn Konstante: Wert und Herkunft der Konstanten
  2738.                               ;   (der Wert ist zur Compile-Zeit bekannt)
  2739.   usedp                       ; falls lexikalisch:
  2740.                               ;   wurde die Variable jemals abgefragt ?
  2741.                               ;   (Eine durch NIL oder T beendete Liste der
  2742.                               ;    Referenzen auf die Variable)
  2743.   really-usedp                ; falls lexikalisch:
  2744.                               ;   wurde die Variable jemals wirklich
  2745.                               ;   (um den Wert zu wissen) abgefragt ?
  2746.   (modified-list '())         ; falls lexikalisch: zu jedem SET auf die Variable
  2747.                               ;   eine Liste (value-anode set-anode . for-value)
  2748.   (replaceable-list '())      ; falls lexikalisch:
  2749.                               ;   zu jeder movable-Variablen, die wΣhrend ihrer
  2750.                               ;   gesamten Existenz denselben Wert wie diese
  2751.                               ;   hat und deswegen ersetzbar ist, jeweils eine
  2752.                               ;   Liste (var init-anode . bind-anode)
  2753.   closurep                    ; falls lexikalisch:
  2754.                               ;   NIL falls im Stack, T falls in der Closure
  2755.   (stackz nil :read-only t)   ; falls lexikalisch:
  2756.                               ;   Stackzustand nach dem Anlegen der Variablen
  2757.                               ;   (falls Variable im Stack: ihr Ort im Stack)
  2758.   (venvc nil :read-only t)    ; falls lexikalisch und in der Closure:
  2759.                               ;   das *venvc*, in dessen erstem Item diese
  2760.                               ;   Variable vorkommt.
  2761. )
  2762. #+CLISP (remprop 'var 'sys::defstruct-description)
  2763.  
  2764. ; (venv-search v) sucht in *venv* nach einer Variablen mit dem Symbol v.
  2765. ; Ergebnis ist:
  2766. ; NIL                   falls nicht gefunden
  2767. ; SPECIAL               falls als Special-deklarierte Variable gefunden
  2768. ; LOCAL, vector, index  falls interpretativ lexikalisch gebunden, Wert im Vektor
  2769. ; T, var                falls lexikalisch gebunden, im Stack oder in der Closure
  2770. (defun venv-search (v &optional (venv *venv*))
  2771.   (when (or (constantp v) (proclaimed-special-p v))
  2772.     (return-from venv-search 'SPECIAL)
  2773.   )
  2774.   (loop
  2775.     (cond ((null venv) (return-from venv-search 'NIL))
  2776.           ((simple-vector-p venv)
  2777.            (do ((l (1- (length venv)))
  2778.                 (i 0 (+ i 2)))
  2779.                ((= i l) (setq venv (svref venv i)))
  2780.              (if (eq v (svref venv i))
  2781.                (let ((val (svref venv (1+ i))))
  2782.                  (return-from venv-search
  2783.                    (if (and (var-p val) #| (eq (var-name val) v) |# )
  2784.                      (if (var-specialp val) 'SPECIAL (values T val))
  2785.                      (if (eq val specdecl) 'SPECIAL (values 'LOCAL venv (1+ i)))
  2786.           )) ) ) ) )
  2787.           (t (compiler-error 'venv-search))
  2788.   ) )
  2789. )
  2790.  
  2791. ; (venv-search-macro v) sucht in *venv* nach einer Variablen mit dem Symbol v.
  2792. ; Ergebnis ist:
  2793. ;   Wenn v ein Symbol-Macro darstellt:  T, Expansion.
  2794. ;   Sonst:                              NIL.
  2795. (defun venv-search-macro (v &optional (venv *venv*))
  2796.   (multiple-value-bind (a b c) (venv-search v venv)
  2797.     (case a
  2798.       ((NIL) (symbol-macro-expand v))
  2799.       ((LOCAL) (and (symbol-macro-p (svref b c))
  2800.                     (values t (sys::%record-ref (svref b c) 0))
  2801.       )        )
  2802.       (t nil)
  2803. ) ) )
  2804.  
  2805. ; (push-*venv* var1 ... varn) erweitert *venv* um var1, ..., varn,
  2806. ; sozusagen wie durch  (dolist (v (list var1 ... varn)) (push v *venv*)).
  2807. (defun push-*venv* (&rest varlist)
  2808.   (when varlist
  2809.     (let ((l (list *venv*)))
  2810.       (dolist (var varlist) (setq l (list* (var-name var) var l)))
  2811.       (setq *venv* (apply #'vector l))
  2812. ) ) )
  2813.  
  2814. ; (zugriff-in-closure var venvc stackz)
  2815. ; liefert zu einer Closure-Variablen var, wie man auf sie zugreifen kann
  2816. ; (von einem Ort aus, an der Stack und das Closure-Environment durch stackz und
  2817. ;  venvc beschrieben werden):
  2818. ; 3 Werte k, n, m; die Variable sitzt in (svref ... 1+m) von
  2819. ;     nil, n, m  : (STACK+4*n)
  2820. ;     k, nil, m  : (svref ... 0)^k VenvConst
  2821. ;     k, n,   m  : ((SP+4*k)+4*n)
  2822. (defun zugriff-in-closure (var venvc stackz &aux (k nil) n)
  2823.   ; Grobschleife, stellt die Closure-Tiefe k ab VenvConst fest:
  2824.   (loop
  2825.     (when (eq venvc (var-venvc var)) (return))
  2826.     (let ((item (car venvc)))
  2827.       (if (null k)
  2828.         (when (not (listp item)) (setq k 0)) ; ZΣhlanfang, (not (listp item)) == (fnode-p item)
  2829.         (when (consp item) (incf k)) ; zΣhlen
  2830.     ) )
  2831.     (setq venvc (cdr venvc))
  2832.   )
  2833.   (if k
  2834.     (setq n nil)
  2835.     (multiple-value-setq (k n) (zugriff-in-stack stackz (cdr (first venvc))))
  2836.   )
  2837.   (let ((m (do ((L (car (first venvc)) (cdr L))
  2838.                 (i 0 (1+ i)))
  2839.                ((eq (car L) var) i)
  2840.        ))  )
  2841.     (values k n m)
  2842. ) )
  2843.  
  2844.  
  2845. ;             K O N S T A N T E N - V E R W A L T U N G
  2846.  
  2847. ; Eine Konstante ist eine Box mit dem Wert der Konstanten:
  2848. (defstruct (const (:copier nil))
  2849.   value               ; Wert der Konstanten
  2850.   form                ; Form, die bei Auswertung value ergibt
  2851.   horizont            ; Gⁿltigkeitsbereich von value und form:
  2852.                       ; :VALUE  -  nur value ist gⁿltig
  2853.                       ;            (dann ist implizit form = `(QUOTE ,value) )
  2854.                       ; :ALL    -  value und form beide gⁿltig
  2855.                       ; :FORM   -  nur form gⁿltig
  2856.     ; Bei *compiling-from-file* = nil ist nur :VALUE und :ALL m÷glich.
  2857.     ; Was im 3. Pass in den Fnode eingetragen wird, ist:
  2858.     ;   Bei *compiling-from-file* = nil: nur value.
  2859.     ;   Bei *compiling-from-file* /= nil:
  2860.     ;     Falls (eq horizont ':value), value, sonst form.
  2861. )
  2862. #+CLISP (remprop 'const 'sys::defstruct-description)
  2863. ; Im 2. Pass werden auch Variablen mit constantp=T als Konstanten behandelt.
  2864.  
  2865.  
  2866. ;           D E K L A R A T I O N E N - V E R W A L T U N G
  2867.  
  2868. (defparameter *declaration-types*
  2869.   '(special ; Bindungen
  2870.     type ftype function ; Typen
  2871.     inline notinline ; Funktionen-Compilation
  2872.     ignore optimize dynamic-extent ; Compiler-Hinweise
  2873.     declaration ; Zusatzdeklarationen
  2874.     ; Typen nach Tabelle 4-1 :
  2875.     array atom bignum bit bit-vector character common compiled-function
  2876.     complex cons double-float fixnum float function hash-table integer keyword
  2877.     list long-float nil null number package pathname random-state ratio rational
  2878.     readtable sequence short-float simple-array simple-bit-vector simple-string
  2879.     simple-vector single-float standard-char stream string string-char symbol t
  2880.     vector
  2881.     ; zusΣtzliche Deklarationen:
  2882.     compile ; Anweisung, da▀ die Form bzw. Funktion zu compilieren ist
  2883.     sys::source ; der Source-Lambdabody (unexpandiert) innerhalb eines Lambdabody
  2884.     sys::in-defun ; zeigt an, zu welcher globalen Funktion der Code geh÷rt
  2885.     ignorable ; markiert Variablen als vielleicht ignorierbar
  2886.               ; (NB: Gensym-Variablen sind immer automatisch ignorable.)
  2887. )  )
  2888.  
  2889. ; mitgegeben vom Interpreter: %denv%
  2890.  
  2891. ; neu konstruiert:
  2892. (defvar *denv*)
  2893. ; *denv* hat dieselbe Gestalt wie %denv% und endet mit %denv%.
  2894. ; *denv* hat die Gestalt (item1 ... itemn), wo jedes item die Bauart
  2895. ; (declaration-type argument ...) hat.
  2896. ; Sonderbehandlung von
  2897. ;   SPECIAL : wird weggelassen, stattdessen in *venv* notiert.
  2898. ;   IGNORE, IGNORABLE : wird weggelassen, stattdessen bei der
  2899. ;                       verarbeitenden Form selber verarbeitet.
  2900. ; ZusΣtzliche Deklaration (INLINING symbol) gegen rekursives Inlining.
  2901.  
  2902. ; (process-declarations declspeclist) pusht die Deklarationen (wie sie von
  2903. ; PARSE-BODY kommen) auf *denv* und liefert:
  2904. ; eine Liste der Special-deklarierten Symbole,
  2905. ; eine Liste der Ignore-deklarierten Symbole,
  2906. ; eine Liste der Ignorable-deklarierten Symbole.
  2907. (defun process-declarations (declspeclist &aux (specials nil) (ignores nil) (ignorables nil))
  2908.   (setq declspeclist (nreverse declspeclist))
  2909.   (dolist (declspec declspeclist)
  2910.     (if (or (atom declspec) (cdr (last declspec)))
  2911.       (c-warn (DEUTSCH "Falsche Deklarationen-Syntax: ~S~%Wird ignoriert."
  2912.                ENGLISH "Bad declaration syntax: ~S~%Will be ignored."
  2913.                FRANCAIS "Mauvaise syntaxe pour une dΘclaration : ~S~%IgnorΘe.")
  2914.               declspec
  2915.       )
  2916.       (let ((declspectype (car declspec)))
  2917.         (if (and (symbolp declspectype)
  2918.                  (or (member declspectype *declaration-types* :test #'eq)
  2919.                      (do ((L *denv* (cdr L)))
  2920.                          ((null L) nil)
  2921.                        (if (and (eq (first (car L)) 'DECLARATION)
  2922.                                 (member declspectype (rest (car L)) :test #'eq)
  2923.                            )
  2924.                          (return t)
  2925.                      ) )
  2926.                      (and *compiling-from-file*
  2927.                        (member declspectype *user-declaration-types* :test #'eq)
  2928.             )    )   )
  2929.           (cond ((eq declspectype 'SPECIAL)
  2930.                  (dolist (x (cdr declspec))
  2931.                    (if (symbolp x)
  2932.                      (push x specials)
  2933.                      (c-warn (DEUTSCH "Nur Symbole k÷nnen SPECIAL-deklariert werden, nicht ~S."
  2934.                               ENGLISH "Non-symbol ~S may not be declared SPECIAL."
  2935.                               FRANCAIS "Seuls les symboles peuvent Ωtre dΘclarΘs SPECIAL, pas ~S.")
  2936.                              x
  2937.                 )) ) )
  2938.                 ((eq declspectype 'IGNORE)
  2939.                  (dolist (x (cdr declspec))
  2940.                    (if (symbolp x)
  2941.                      (push x ignores)
  2942.                      (c-warn (DEUTSCH "Nur Symbole k÷nnen IGNORE-deklariert werden, nicht ~S."
  2943.                               ENGLISH "Non-symbol ~S may not be declared IGNORE."
  2944.                               FRANCAIS "Seuls les symboles peuvent Ωtre dΘclarΘs IGNORE, pas ~S.")
  2945.                              x
  2946.                 )) ) )
  2947.                 ((eq declspectype 'IGNORABLE)
  2948.                  (dolist (x (cdr declspec))
  2949.                    (if (symbolp x)
  2950.                      (push x ignorables)
  2951.                      (c-warn (DEUTSCH "Nur Symbole k÷nnen IGNORABLE-deklariert werden, nicht ~S."
  2952.                               ENGLISH "Non-symbol ~S may not be declared IGNORABLE."
  2953.                               FRANCAIS "Seuls les symboles peuvent Ωtre dΘclarΘs IGNORABLE.")
  2954.                              x
  2955.                 )) ) )
  2956.                 (t (push declspec *denv*))
  2957.           )
  2958.           (c-warn (DEUTSCH "Unbekannte Deklaration ~S.~%Die ganze Deklaration ~S wird ignoriert."
  2959.                    ENGLISH "Unknown declaration ~S.~%The whole declaration will be ignored."
  2960.                    FRANCAIS "DΘclaration inconnue ~S.~%Toute la dΘclaration ~S est ignorΘe.")
  2961.                   declspectype declspec
  2962.   ) ) ) ) )
  2963.   (values specials ignores ignorables)
  2964. )
  2965.  
  2966. ; (declared-notinline fun denv) stellt fest, ob fun - ein Symbol, das eine
  2967. ; globale Funktion, die nicht durch eine lokale Funktionsdefinition verdeckt
  2968. ; ist, benennt - in denv als NOTINLINE deklariert ist.
  2969. ; Was ist mit lokalen Funktionen ??
  2970. (defun declared-notinline (fun &optional (denv *denv*))
  2971.   (when (member `(INLINING ,fun) *denv* :test #'equal)
  2972.     (return-from declared-notinline t) ; keine Funktion rekursiv inline expandieren!
  2973.   )
  2974.   (loop
  2975.     (when (atom denv)
  2976.       (when *compiling-from-file*
  2977.         (when (member fun *notinline-functions* :test #'equal) (return t))
  2978.         (when (member fun *inline-functions* :test #'equal) (return nil))
  2979.       )
  2980.       (return (eq (get (get-funname-symbol fun) 'inlinable) 'notinline))
  2981.     )
  2982.     (let ((declspec (car denv)))
  2983.       (when (and (eq (car declspec) 'INLINE) (member fun (cdr declspec) :test #'equal))
  2984.         (return nil)
  2985.       )
  2986.       (when (and (eq (car declspec) 'NOTINLINE) (member fun (cdr declspec) :test #'equal))
  2987.         (return t)
  2988.     ) )
  2989.     (setq denv (cdr denv))
  2990. ) )
  2991.  
  2992.  
  2993. ;             F U N K T I O N E N - V E R W A L T U N G
  2994.  
  2995. ; Ein FNODE enthΣlt die n÷tige Information fⁿr eine Funktion:
  2996. (defstruct (fnode (:copier nil))
  2997.   name            ; Name, ein Symbol oder (SETF symbol)
  2998.   code            ; Code dieser Funktion (zuerst nichts, dann ein ANODE,
  2999.                   ; dann eine Closure)
  3000.   ; Ab hier Beschreibungen fⁿr die kommende Closure:
  3001.   venvconst       ; Flag, ob das Venv dieser Funktion explizit beim Aufbau
  3002.                   ; mitgegeben werden mu▀ (oder immer NIL ist)
  3003.   venvc           ; Aussehen des Venv, das dieser Funktion beim Aufbau
  3004.                   ; mitgegeben werden mu▀ (wenn ⁿberhaupt)
  3005.   Blocks-Offset   ; Anzahl der Konstanten bis hierher
  3006.   (Blocks nil)    ; Liste der Block-Konstrukte, die dieser Funktion beim Aufbau
  3007.                   ; mitgegeben werden mⁿssen
  3008.   Tagbodys-Offset ; Anzahl der Konstanten bis hierher
  3009.   (Tagbodys nil)  ; Liste der Tagbody-Konstrukte, die dieser Funktion beim
  3010.                   ; Aufbau mitgegeben werden mⁿssen
  3011.   Keyword-Offset  ; Anzahl der lokalen Konstanten bis hierher
  3012.                   ; = Anfangsoffset der Keywords in FUNC
  3013.                   ; (also =0 genau dann, wenn die Funktion autonom ist)
  3014.   (req-anz 0)     ; Anzahl der required parameter
  3015.   (opt-anz 0)     ; Anzahl der optionalen Parameter
  3016.   (rest-flag nil) ; Flag, ob &REST - Parameter angegeben.
  3017.   (keyword-flag nil) ; Flag, ob &KEY - Parameter angegeben.
  3018.   (keywords nil)  ; Liste der Keyword-Konstanten (in der richtigen Reihenfolge)
  3019.   allow-other-keys-flag ; &ALLOW-OTHER-KEYS-Flag
  3020.   Consts-Offset   ; Anzahl der lokalen Konstanten bis hierher
  3021.   (consts nil)    ; Liste der sonstigen Konstanten dieser Funktion
  3022.                   ; Diese Liste wird erst im 2. Pass aufgebaut.
  3023.   (consts-forms nil) ; Liste der evtl. Formen, die diese Konstanten ergeben
  3024.   enclosing       ; lexikalisch nΣchste darⁿberliegende Funktion (oder NIL)
  3025.   gf-p            ; Flag, ob eine generische Funktion produziert wird
  3026.                   ; (impliziert Blocks-Offset = Tagbodys-Offset = Keyword-Offset = 0 oder 1)
  3027. )
  3028. #+CLISP (remprop 'fnode 'sys::defstruct-description)
  3029.  
  3030. ; die aktuelle Funktion, ein FNODE:
  3031. (defvar *func*)
  3032. ; das Label am Beginn des Codes der aktuellen Funktion:
  3033. (defvar *func-start-label*)
  3034.  
  3035. ; Anzahl der bisher in der aktuellen Funktion aufgetretenen anonymen
  3036. ; Funktionen (Lambda-Ausdrⁿcke):
  3037. (defvar *anonymous-count*)
  3038.  
  3039. ; *no-code* = T besagt, da▀ kein Code produziert werden soll:
  3040. (defvar *no-code*)
  3041. ; Dies verhindert, da▀ Variablen unn÷tigerweise in die Closure gesteckt oder
  3042. ; Optimierungen unn÷tigerweise unterlassen werden.
  3043.  
  3044.  
  3045. ;                 F O R M E N - V E R W A L T U N G
  3046.  
  3047. ; Bei jeder Rekursion werden folgende Variablen dynamisch gebunden:
  3048. (defvar *form*)      ; die aktuelle Form
  3049. (defvar *for-value*) ; ob und welche Werte der Form von Belang sind:
  3050.                      ; NIL : Werte sind irrelevant
  3051.                      ; ONE : nur der erste Wert ist relevant
  3052.                      ; ALL : alle Werte sind relevant
  3053.  
  3054. ; Ein ANODE ist die Codierung der Information, die beim Compilieren einer Form
  3055. ; gebraucht wird.
  3056. (defstruct (anode
  3057.             (:constructor mk-anode (#+COMPILER-DEBUG source
  3058.                                     type
  3059.                                     #+COMPILER-DEBUG sub-anodes
  3060.                                     seclass
  3061.                                     code
  3062.                                     #+COMPILER-DEBUG stackz
  3063.             )                      )
  3064.             (:copier nil)
  3065.            )
  3066.   #+COMPILER-DEBUG
  3067.   source              ; die zu dieser Form geh÷rige Source, meist eine Form
  3068.                       ; (nur zu Debugzwecken erforderlich)
  3069.   type                ; Typ des ANODE (CALL, PRIMOP, VAR, LET, SETQ, ...)
  3070.   #+COMPILER-DEBUG
  3071.   sub-anodes          ; alle ANODEs der Unterformen
  3072.   seclass             ; Seiteneffekt-Klassifikation
  3073.   code                ; erzeuger LAP-Code, eine Liste aus LAP-Anweisungen
  3074.                       ; und ANODEs
  3075.   #+COMPILER-DEBUG
  3076.   stackz              ; Zustand der Stacks beim Eintritt in den zugeh÷rigen
  3077.                       ; LAP-Code
  3078. )
  3079. #+CLISP (remprop 'anode 'sys::defstruct-description)
  3080. ; (make-anode ...) ist dasselbe wie mk-anode, nur da▀ dabei die Argumente
  3081. ; mit Keywords markiert werden und wegen #+COMPILER-DEBUG unn÷tige
  3082. ; Komponenten trotzdem dastehen dⁿrfen.
  3083. (eval-when (compile eval)
  3084.   (defmacro make-anode (&key
  3085.                         (source `*form*)
  3086.                         type
  3087.                         (sub-anodes `'())
  3088.                         seclass
  3089.                         code
  3090.                         (stackz `*stackz*)
  3091.                        )
  3092.     `(mk-anode #+COMPILER-DEBUG ,source
  3093.                ,type
  3094.                #+COMPILER-DEBUG ,sub-anodes
  3095.                ,seclass
  3096.                ,code
  3097.                #+COMPILER-DEBUG ,stackz
  3098.      )
  3099. ) )
  3100.  
  3101. #|
  3102. ; Eine Seiteneffekt-Klasse (SECLASS) ist ein Indikator:
  3103. ; NIL : dieses ANODE produziert keine Seiteneffekte,
  3104. ;       sein Wert ist nicht von Seiteneffekten beeinflu▀bar.
  3105. ; VAL : dieses ANODE produziert keine Seiteneffekte,
  3106. ;       sein Wert ist aber von Seiteneffekten beeinflu▀bar.
  3107. ; T   : dieses ANODE kann Seiteneffekte produzieren.
  3108. ; Somit:
  3109. ;   Falls der Wert uninteressant ist, kann ein ANODE mit SECLASS = NIL/VAL
  3110. ;   weggelassen werden.
  3111. ;   In der Reihenfolge der Auswertung dⁿrfen vertauscht werden ANODEs mit
  3112. ;   SECLASS     NIL-NIL, NIL-VAL, NIL-T, VAL-VAL.
  3113.  
  3114. ; (seclass-or class1 ... classk) bestimmt die Gesamtklasse der Ausfⁿhrung
  3115. ; aller Klassen.
  3116. (defun seclass-or (&rest args)
  3117.   (cond ((member 'T args :test #'eq) 'T)
  3118.         ((member 'VAL args :test #'eq) 'VAL)
  3119.         (t 'NIL)
  3120. ) )
  3121. ; Dito, mit nur 2 Argumenten
  3122. (defun seclass-or-2 (seclass1 seclass2)
  3123.   (or (eq seclass1 'T) seclass2 seclass1)
  3124. )
  3125. ; Damit die Liste der sub-anodes nicht gebildet werden mu▀, aber dennoch
  3126. ; der zu dieser Liste geh÷rige Seiteneffektklasse berechnet werden kann:
  3127. (eval-when (compile eval)
  3128.   (defmacro anodes-seclass-or (&rest anodeforms)
  3129.     (reduce #'(lambda (form1 form2) `(SECLASS-OR-2 ,form1 ,form2))
  3130.             (mapcar #'(lambda (anodeform) `(ANODE-SECLASS ,anodeform))
  3131.                     anodeforms
  3132.   ) )       )
  3133.   (define-modify-macro seclass-or-f (anode) seclass-or-anode)
  3134.   (defmacro seclass-or-anode (seclass anode)
  3135.     `(SECLASS-OR-2 ,seclass (ANODE-SECLASS ,anode))
  3136.   )
  3137. )
  3138. (defun anodelist-seclass-or (anodelist)
  3139.   (apply #'seclass-or (mapcar #'anode-seclass anodelist))
  3140. )
  3141.  
  3142. ; Stellt fest, ob zwei Anodes in der Reihenfolge ihrer Auswertung vertauscht
  3143. ; werden k÷nnen - vorausgesetzt, die StackzustΣnde lassen das zu.
  3144. (defun anodes-commute (anode1 anode2)
  3145.   (let ((seclass1 (anode-seclass anode1))
  3146.         (seclass2 (anode-seclass anode2)))
  3147.     (or (eq seclass1 'NIL) (eq seclass2 'NIL)
  3148.         (and (eq seclass1 'VAL) (eq seclass2 'VAL))
  3149. ) ) )
  3150. |#
  3151.  
  3152. ; Eine Seiteneffekt-Klasse (SECLASS) ist ein Indikator (uses . modifies):
  3153. ; uses = NIL : dieses Anode ist nicht von Seiteneffekten beeinflu▀bar,
  3154. ;        Liste : dieses Anode ist vom Wert der Variablen in der Liste abhΣngig,
  3155. ;        T : dieses Anode ist m÷glicherweise von jedem Seiteneffekt beeinflu▀bar.
  3156. ; modifies = NIL : dieses Anode produziert keine Seiteneffekte
  3157. ;            Liste : ... produziert Seiteneffekte nur auf die Werte der
  3158. ;                    Variablen in der Liste
  3159. ;            T : ... produziert Seiteneffekte unbekannten Ausma▀es.
  3160. ; (Variablen sind hier VAR-Structures fⁿr lexikalische und Symbole fⁿr
  3161. ; dynamische Variablen.)
  3162. ; Somit:
  3163. ;   Falls der Wert uninteressant ist, kann ein ANODE mit SECLASS-modifies=NIL
  3164. ;   weggelassen werden.
  3165. ;   In der Reihenfolge der Auswertung dⁿrfen vertauscht werden ANODEs mit
  3166. ;   SECLASS, deren uses- und modifies-Teil ⁿber Kreuz disjunkt sind.
  3167.  
  3168. ; (seclass-or class1 ... classk) bestimmt die Gesamtklasse der Ausfⁿhrung
  3169. ; aller Klassen.
  3170. (defun seclass-or (&rest args)
  3171.   (if (null args) '(NIL . NIL) (reduce #'seclass-or-2 args))
  3172. )
  3173. ; Dito, mit nur 2 Argumenten
  3174. (defun seclass-or-2 (seclass1 seclass2)
  3175.   (cons (if (or (eq (car seclass1) 'T) (eq (car seclass2) 'T))
  3176.           'T
  3177.           (union (car seclass1) (car seclass2))
  3178.         )
  3179.         (if (or (eq (cdr seclass1) 'T) (eq (cdr seclass2) 'T))
  3180.           'T
  3181.           (union (cdr seclass1) (cdr seclass2))
  3182. ) )     )
  3183.  
  3184. ; Damit die Liste der sub-anodes nicht gebildet werden mu▀, aber dennoch
  3185. ; der zu dieser Liste geh÷rige Seiteneffektklasse berechnet werden kann:
  3186. (eval-when (compile eval)
  3187.   (defmacro anodes-seclass-or (&rest anodeforms)
  3188.     (reduce #'(lambda (form1 form2) `(SECLASS-OR-2 ,form1 ,form2))
  3189.             (mapcar #'(lambda (anodeform) `(ANODE-SECLASS ,anodeform))
  3190.                     anodeforms
  3191.   ) )       )
  3192.   (define-modify-macro seclass-or-f (anode) seclass-or-anode)
  3193.   (defmacro seclass-or-anode (seclass anode)
  3194.     `(SECLASS-OR-2 ,seclass (ANODE-SECLASS ,anode))
  3195.   )
  3196. )
  3197. (defun anodelist-seclass-or (anodelist)
  3198.   (apply #'seclass-or (mapcar #'anode-seclass anodelist))
  3199. )
  3200.  
  3201. ; Seiteneffekte auf weiter innen gebundene lexikalische Variablen zΣhlen
  3202. ; nicht und werden deshalb eliminiert:
  3203. (defun seclass-without (seclass varlist)
  3204.   (flet ((bound (var) (member var varlist))) ; testet, ob var gebunden wird
  3205.     ; (Dynamische Variablen werden nicht eliminiert; sie sind in varlist
  3206.     ; als VAR-Structures und in seclass als Symbole enthalten.)
  3207.     (cons (if (eq (car seclass) 'T) 'T (remove-if #'bound (car seclass)))
  3208.           (if (eq (cdr seclass) 'T) 'T (remove-if #'bound (cdr seclass)))
  3209. ) ) )
  3210.  
  3211. ; Stellt fest, ob zwei Anodes in der Reihenfolge ihrer Auswertung vertauscht
  3212. ; werden k÷nnen - vorausgesetzt, die StackzustΣnde lassen das zu.
  3213. (defun anodes-commute (anode1 anode2)
  3214.   (seclasses-commute (anode-seclass anode1) (anode-seclass anode2))
  3215. )
  3216. (defun seclasses-commute (seclass1 seclass2)
  3217.   (flet ((disjoint-p (uses modifies)
  3218.            (or (null uses) (null modifies)
  3219.                (and (not (eq uses 'T)) (not (eq modifies 'T))
  3220.                     (null (intersection uses modifies))
  3221.         )) )   )
  3222.     (and (disjoint-p (car seclass1) (cdr seclass2))
  3223.          (disjoint-p (car seclass2) (cdr seclass1))
  3224. ) ) )
  3225.  
  3226.  
  3227. ;            H I L F S F U N K T I O N E N
  3228.  
  3229. ; Zerlegt einen Funktionsnamen in Package und String.
  3230. (defun get-funname-string+pack (funname)
  3231.   (if (atom funname)
  3232.     (values (symbol-name funname) (symbol-package funname))
  3233.     (values (concatenate 'string "(" (symbol-name (first funname)) " "
  3234.                                      (symbol-name (second funname)) ")"
  3235.             )
  3236.             (symbol-package (second funname))
  3237. ) ) )
  3238.  
  3239. ; Liefert einen Funktionsnamen, der sich aus der Package und dem Printname eines
  3240. ; gegebenen Funktionsnamen, einem Bindestrich und einem Suffix zusammensetzt.
  3241. (defun symbol-suffix (funname suffix)
  3242.   (if (and (symbolp funname) (null (symbol-package funname))
  3243.            (function-name-p suffix)
  3244.       )
  3245.     suffix
  3246.     (multiple-value-bind (name pack) (get-funname-string+pack funname)
  3247.       ; suffix in einen String umwandeln:
  3248.       (cond ((symbolp suffix) (setq suffix (symbol-name suffix)))
  3249.             ((not (stringp suffix))
  3250.              (setq suffix (write-to-string suffix :escape nil :base 10 :radix nil :readably nil))
  3251.       )     )
  3252.       ; neues Symbol bilden:
  3253.       (let ((new-name (concatenate 'string name "-" suffix)))
  3254.         (if pack (intern new-name pack) (make-symbol new-name))
  3255. ) ) ) )
  3256.  
  3257. ; (C-COMMENT controlstring . args)
  3258. ; gibt eine Zusatzinformation des Compilers aus (mittels FORMAT).
  3259. (defun c-comment (cstring &rest args)
  3260.   (let ((dest (if *compile-verbose* *c-error-output* *c-listing-output*)))
  3261.     (when dest (apply #'format dest cstring args))
  3262. ) )
  3263.  
  3264. ; (C-SOURCE-LOCATION)
  3265. ; liefert eine Beschreibung, an welcher Source-Stelle man sich befindet.
  3266. (defun c-source-location ()
  3267.   (if (and *compiling-from-file* *compile-file-lineno1* *compile-file-lineno2*)
  3268.     (format nil
  3269.             (if (= *compile-file-lineno1* *compile-file-lineno2*)
  3270.               (DEUTSCH " in Zeile ~D"
  3271.                ENGLISH " in line ~D"
  3272.                FRANCAIS " dans la ligne ~D")
  3273.               (DEUTSCH " in Zeilen ~D..~D"
  3274.                ENGLISH " in lines ~D..~D"
  3275.                FRANCAIS " dans les lignes ~D..~D")
  3276.             )
  3277.             *compile-file-lineno1* *compile-file-lineno2*
  3278.     )
  3279.     ""
  3280. ) )
  3281.  
  3282. (defvar *warning-count*)
  3283. ; (C-WARN controlstring . args)
  3284. ; gibt eine Compiler-Warnung aus (mittels FORMAT).
  3285. (defun c-warn (cstring &rest args)
  3286.   (setq cstring
  3287.     (concatenate 'string (DEUTSCH "~%WARNUNG~@[ in Funktion ~S~]~A :~%"
  3288.                           ENGLISH "~%WARNING~@[ in function ~S~]~A :~%"
  3289.                           FRANCAIS "~%AVERTISSEMENT~@[ dans la fonction ~S~]~A :~%")
  3290.                          cstring
  3291.   ) )
  3292.   (incf *warning-count*)
  3293.   (let ((dest (if *compile-warnings* *c-error-output* *c-listing-output*)))
  3294.     (when dest
  3295.       (apply #'format dest cstring
  3296.              (and (boundp '*func*) (fnode-p *func*) (fnode-name *func*))
  3297.              (c-source-location)
  3298.              args
  3299. ) ) ) )
  3300.  
  3301. (defvar *error-count*)
  3302. ; (C-ERROR controlstring . args)
  3303. ; gibt einen Compiler-Error aus (mittels FORMAT) und beendet das laufende C-FORM.
  3304. (defun c-error (cstring &rest args)
  3305.   (incf *error-count*)
  3306.   (let ((in-function
  3307.           (and (boundp '*func*) (fnode-p *func*) (fnode-name *func*))
  3308.        ))
  3309.     (when in-function
  3310.       (when *compiling-from-file* (pushnew in-function *functions-with-errors*))
  3311.     )
  3312.     (format *c-error-output*
  3313.             (DEUTSCH "~%ERROR~@[ in Funktion ~S~]~A :~%~?"
  3314.              ENGLISH "~%ERROR~@[ in function ~S~]~A :~%~?"
  3315.              FRANCAIS "~%ERREUR~@[ dans la fonction ~S~]~A :~%~?")
  3316.             in-function (c-source-location)
  3317.             cstring args
  3318.   ) )
  3319.   (throw 'c-error
  3320.     (make-anode :source NIL
  3321.                 :type 'ERROR
  3322.                 :sub-anodes '()
  3323.                 :seclass '(NIL . NIL)
  3324.                 :code '((NIL))
  3325. ) ) )
  3326.  
  3327. ; (c-eval-when-compile form) fⁿhrt eine Form zur Compile-Zeit aus.
  3328. (defun c-eval-when-compile (form)
  3329.   (when (and *compiling-from-file* *liboutput-stream*)
  3330.     ; Form auf den Liboutput-Stream schreiben:
  3331.     (terpri *liboutput-stream*)
  3332.     (write form :stream *liboutput-stream* :pretty t
  3333.                 :readably t
  3334.                 ; :closure t :circle t :array t :gensym t
  3335.                 ; :escape t :level nil :length nil :radix t
  3336.   ) )
  3337.   ; Form evaluieren:
  3338.   (eval form)
  3339. )
  3340.  
  3341. ; (c-constantp form) stellt fest, ob form im Compiler als Konstante gehandhabt
  3342. ; wird.
  3343. (defun c-constantp (form)
  3344.   (if (atom form)
  3345.     (or (numberp form) (characterp form) (stringp form) (bit-vector-p form)
  3346.         (and (symbolp form)
  3347.              (cond ((keywordp form) t)
  3348.                    ((eq (symbol-package form) *lisp-package*)
  3349.                     (constantp form)
  3350.                    )
  3351.                    (t (not (null (assoc form *constant-special-vars*))))
  3352.     )   )    )
  3353.     (and (eq (first form) 'QUOTE) (consp (cdr form)) (null (cddr form)))
  3354. ) )
  3355.  
  3356. ; (c-constant-value form) liefert den Wert einer Konstanten
  3357. (defun c-constant-value (form)
  3358.   (if (atom form)
  3359.     (cond ((numberp form) form)
  3360.           ((characterp form) form)
  3361.           ((stringp form) form)
  3362.           ((bit-vector-p form) form)
  3363.           ((symbolp form)
  3364.            (cond ((keywordp form) form)
  3365.                  ((eq (symbol-package form) *lisp-package*)
  3366.                   (symbol-value form)
  3367.                  )
  3368.                  (t (cdr (assoc form *constant-special-vars*)))
  3369.     )     ))
  3370.     (second form)
  3371. ) )
  3372.  
  3373. ; (anode-constantp anode) stellt fest, ob der Anode einen konstanten (und
  3374. ; zur Compile-Zeit bekannten) Wert liefert.
  3375. (defun anode-constantp (anode)
  3376.   ; Anode liefert konstanten Wert jedenfalls dann, wenn sein Code
  3377.   ; (nach TRAVERSE-ANODE) genau aus ((CONST ...)) bestehen wⁿrde.
  3378.   (let ((code (anode-code anode)))
  3379.     (and (consp code) (null (cdr code)) ; Liste der LΣnge 1
  3380.          (let ((item (car code)))
  3381.             (cond ((consp item)
  3382.                    (and (eq (first item) 'CONST)
  3383.                         (not (eq (const-horizont (second item)) ':form))
  3384.                   ))
  3385.                   ((anode-p item) (anode-constantp item))
  3386. ) ) )    )  )
  3387.  
  3388. ; (anode-constant-value anode) liefert den Wert eines konstanten Anode.
  3389. (defun anode-constant (anode)
  3390.   (let ((item (car (anode-code anode))))
  3391.     (cond ((consp item) (second item))
  3392.           (t #|(anode-p item)|# (anode-constant item))
  3393. ) ) )
  3394. (defun anode-constant-value (anode)
  3395.   (const-value (anode-constant anode))
  3396. )
  3397.  
  3398. ; (new-const value) liefert eine Konstante in *func* mit dem Wert value
  3399. ; im 1. Pass
  3400. (defun new-const (value)
  3401.   (make-const :horizont ':value :value value)
  3402. )
  3403.  
  3404. ; (make-label for-value) liefert ein neues Label. for-value (NIL/ONE/ALL)
  3405. ; gibt an, welche der Werte nach dem Label gebraucht werden.
  3406. (defun make-label (for-value)
  3407.   (let ((label (gensym)))
  3408.     (setf (symbol-value label) '()) ; Referenzliste fⁿr 2. Pass := leer
  3409.     (setf (get label 'for-value) for-value)
  3410.     label
  3411. ) )
  3412.  
  3413. ; liefert eine Special-Variable
  3414. (defun make-special-var (symbol)
  3415.   (make-var :name symbol :specialp t
  3416.             :constantp (c-constantp symbol)
  3417.             :constant (if (c-constantp symbol)
  3418.                         (make-const :horizont ':all
  3419.                                     :value (c-constant-value symbol)
  3420.                                     :form symbol
  3421. ) )                   ) )
  3422.  
  3423.  
  3424. ;                     E R S T E R   P A S S
  3425.  
  3426. ; (test-list L) stellt fest, ob L eine echte Liste ist, die mit NIL endet
  3427. ; und mindestens l1, h÷chstens aber l2 Elemente hat. Sonst Error.
  3428. (defun test-list (L &optional (l1 0) (l2 nil))
  3429.   (unless (and (listp L) (null (cdr (last L))))
  3430.     (c-error (DEUTSCH "Dotted list im Code: ~S"
  3431.               ENGLISH "Code contains dotted list ~S"
  3432.               FRANCAIS "Paire pointΘe dans le code en ~S")
  3433.              L
  3434.   ) )
  3435.   (unless (>= (length L) l1)
  3436.     (c-error (DEUTSCH "Form zu kurz (zu wenig Argumente): ~S"
  3437.               ENGLISH "Form too short, too few arguments: ~S"
  3438.               FRANCAIS "Forme trop courte (trop peu d'arguments) : ~S")
  3439.              L
  3440.   ) )
  3441.   (when l2
  3442.     (unless (<= (length L) l2)
  3443.       (c-error (DEUTSCH "Form zu lang (zu viele Argumente): ~S"
  3444.                 ENGLISH "Form too long, too many arguments: ~S"
  3445.                 FRANCAIS "Forme trop longue (trop d'arguments) : ~S")
  3446.                L
  3447.   ) ) )
  3448. )
  3449.  
  3450. ; c-form-table enthΣlt zu allen Funktionen/Specialforms/Macros, die speziell
  3451. ; behandelt werden mⁿssen, die Behandlungsfunktion (ohne Argumente aufzurufen).
  3452. (defconstant c-form-table
  3453.   (let ((hashtable (make-hash-table :test #'eq)))
  3454.     (mapc
  3455.       #'(lambda (acons) (setf (gethash (car acons) hashtable) (cdr acons)))
  3456.       `(; Special forms:
  3457.           (QUOTE . c-QUOTE)
  3458.           (PROGN . c-PROGN)
  3459.           (LET . ,#'(lambda () (c-LET/LET* nil)))
  3460.           (LET* . ,#'(lambda () (c-LET/LET* t)))
  3461.           (IF . c-IF)
  3462.           (SETQ . c-SETQ)
  3463.           (BLOCK . c-BLOCK)
  3464.           (RETURN-FROM . c-RETURN-FROM)
  3465.           (TAGBODY . c-TAGBODY)
  3466.           (GO . c-GO)
  3467.           (FUNCTION . c-FUNCTION)
  3468.           (MULTIPLE-VALUE-BIND . c-MULTIPLE-VALUE-BIND)
  3469.           (MULTIPLE-VALUE-SETQ . c-MULTIPLE-VALUE-SETQ)
  3470.           (AND . c-AND)
  3471.           (OR . c-OR)
  3472.           (WHEN . c-WHEN)
  3473.           (UNLESS . c-UNLESS)
  3474.           (COND . c-COND)
  3475.           (PSETQ . c-PSETQ)
  3476.           (MULTIPLE-VALUE-CALL . c-MULTIPLE-VALUE-CALL)
  3477.           (PROG1 . c-PROG1)
  3478.           (PROG2 . c-PROG2)
  3479.           (THE . c-THE)
  3480.           (CATCH . c-CATCH)
  3481.           (THROW . c-THROW)
  3482.           (UNWIND-PROTECT . c-UNWIND-PROTECT)
  3483.           (PROGV . c-PROGV)
  3484.           (MULTIPLE-VALUE-LIST . c-MULTIPLE-VALUE-LIST)
  3485.           (MULTIPLE-VALUE-PROG1 . c-MULTIPLE-VALUE-PROG1)
  3486.           (FLET . c-FLET)
  3487.           (LABELS . c-LABELS)
  3488.           (MACROLET . c-MACROLET)
  3489.           (SYMBOL-MACROLET . c-SYMBOL-MACROLET)
  3490.           (COMPILER-LET . c-COMPILER-LET)
  3491.           (EVAL-WHEN . c-EVAL-WHEN)
  3492.           (DECLARE . c-DECLARE)
  3493.           (LOAD-TIME-VALUE . c-LOAD-TIME-VALUE)
  3494.           (LOCALLY . c-LOCALLY)
  3495.         ; Macros:
  3496.           (CASE . c-CASE)
  3497.           (%GENERIC-FUNCTION-LAMBDA . c-%GENERIC-FUNCTION-LAMBDA)
  3498.           (%OPTIMIZE-FUNCTION-LAMBDA . c-%OPTIMIZE-FUNCTION-LAMBDA)
  3499.           (CLOS:GENERIC-FLET . c-GENERIC-FLET)
  3500.           (CLOS:GENERIC-LABELS . c-GENERIC-LABELS)
  3501.           (HANDLER-BIND . c-HANDLER-BIND)
  3502.           (SYS::%HANDLER-BIND . c-HANDLER-BIND)
  3503.           (SYS::CONSTANT-EQL . c-CONSTANT-EQL)
  3504.         ; Inline-compilierte Funktionen:
  3505.           (FUNCALL . c-FUNCALL)
  3506.           (SYS::%FUNCALL . c-FUNCALL)
  3507.           (APPLY . c-APPLY)
  3508.           (+ . c-PLUS)
  3509.           (- . c-MINUS)
  3510.           (SYS::SVSTORE . c-SVSTORE)
  3511.           (EQ . c-EQ)
  3512.           (EQL . c-EQL)
  3513.           (EQUAL . c-EQUAL)
  3514.           (MAPCAR . c-MAPCAR)
  3515.           (MAPLIST . c-MAPLIST)
  3516.           (MAPC . c-MAPC)
  3517.           (MAPL . c-MAPL)
  3518.           (MAPCAN . c-MAPCAN)
  3519.           (MAPCON . c-MAPCON)
  3520.           (MAPCAP . c-MAPCAP)
  3521.           (MAPLAP . c-MAPLAP)
  3522.           (TYPEP . c-TYPEP)
  3523.           (FORMAT . c-FORMAT)
  3524.           (REMOVE-IF . c-REMOVE-IF)
  3525.           (REMOVE-IF-NOT . c-REMOVE-IF-NOT)
  3526.           (DELETE-IF . c-DELETE-IF)
  3527.           (DELETE-IF-NOT . c-DELETE-IF-NOT)
  3528.           (SUBSTITUTE-IF . c-SUBSTITUTE-IF)
  3529.           (SUBSTITUTE-IF-NOT . c-SUBSTITUTE-IF-NOT)
  3530.           (NSUBSTITUTE-IF . c-NSUBSTITUTE-IF)
  3531.           (NSUBSTITUTE-IF-NOT . c-NSUBSTITUTE-IF-NOT)
  3532.           (FIND-IF . c-FIND-IF)
  3533.           (FIND-IF-NOT . c-FIND-IF-NOT)
  3534.           (POSITION-IF . c-POSITION-IF)
  3535.           (POSITION-IF-NOT . c-POSITION-IF-NOT)
  3536.           (COUNT-IF . c-COUNT-IF)
  3537.           (COUNT-IF-NOT . c-COUNT-IF-NOT)
  3538.           (SUBST-IF . c-SUBST-IF)
  3539.           (SUBST-IF-NOT . c-SUBST-IF-NOT)
  3540.           (NSUBST-IF . c-NSUBST-IF)
  3541.           (NSUBST-IF-NOT . c-NSUBST-IF-NOT)
  3542.           (MEMBER-IF . c-MEMBER-IF)
  3543.           (MEMBER-IF-NOT . c-MEMBER-IF-NOT)
  3544.           (ASSOC-IF . c-ASSOC-IF)
  3545.           (ASSOC-IF-NOT . c-ASSOC-IF-NOT)
  3546.           (RASSOC-IF . c-RASSOC-IF)
  3547.           (RASSOC-IF-NOT . c-RASSOC-IF-NOT)
  3548.     )  )
  3549.     hashtable
  3550. ) )
  3551. ; Diese Tabelle mu▀ alle Special-Forms enthalten:
  3552. (do-all-symbols (sym)
  3553.   (when (and (special-form-p sym) (not (gethash sym c-form-table)))
  3554.     (compiler-error 'c-form-table)
  3555. ) )
  3556.  
  3557. ; compiliert eine Form.
  3558. ; Dabei ergibt sich kein Code, falls keine Werte gebraucht werden und die Form
  3559. ; keine Seiteneffekte produziert.
  3560. (defun c-form (*form* &optional (*for-value* *for-value*))
  3561.  (let
  3562.   ((anode
  3563.     (catch 'c-error
  3564.       (if (atom *form*)
  3565.         (cond ((symbolp *form*)
  3566.                (multiple-value-bind (macrop expansion)
  3567.                    (venv-search-macro *form* *venv*)
  3568.                  (if macrop ; Symbol-Macro ?
  3569.                    (c-form expansion) ; -> expandieren
  3570.                    (c-VAR *form*)
  3571.               )) )
  3572.               ((or (numberp *form*) (characterp *form*) (stringp *form*)
  3573.                    (bit-vector-p *form*)
  3574.                    ;; X3J13 vote <72> conditionally implemented: check *package*
  3575.                    (member (find-package "COMMON-LISP") (package-use-list *package*))
  3576.                )
  3577.                (c-CONST)
  3578.               )
  3579.               (t (c-error (DEUTSCH "Das ist keine gⁿltige Form: ~S"
  3580.                            ENGLISH "Invalid form: ~S"
  3581.                            FRANCAIS "Forme invalide : ~S")
  3582.                           *form*
  3583.         )     )  )
  3584.         (let ((fun (first *form*)))
  3585.           (if (function-name-p fun)
  3586.             (multiple-value-bind (a b c) (fenv-search fun)
  3587.               (declare (ignore b))
  3588.               (if (null a)
  3589.                 ; nicht lokal definiert
  3590.                 (let ((handler (gethash fun c-form-table)))
  3591.                   (if handler ; Behandlungsfunktion gefunden?
  3592.                     ; also (symbolp fun)
  3593.                     (if (or (special-form-p fun) (macro-function fun)
  3594.                             (not (declared-notinline fun))
  3595.                         )
  3596.                       (funcall handler) ; ja -> aufrufen
  3597.                       ; normaler Aufruf globaler Funktion
  3598.                       (c-GLOBAL-FUNCTION-CALL fun)
  3599.                     )
  3600.                     ; nein -> jedenfalls keine Special-Form (die sind ja
  3601.                     ; alle in der Tabelle).
  3602.                     (if (and (symbolp fun) (macro-function fun)) ; globaler Macro ?
  3603.                       (c-form (macroexpand-1 *form* (vector *venv* *fenv*))) ; -> expandieren
  3604.                       ; globale Funktion
  3605.                       (if (and (equal fun (fnode-name *func*))
  3606.                                (not (declared-notinline fun))
  3607.                                (member `(SYS::IN-DEFUN ,fun) *denv* :test #'equal)
  3608.                           )
  3609.                         ; rekursiver Aufruf der aktuellen globalen Funktion
  3610.                         (c-LOCAL-FUNCTION-CALL fun (cons *func* nil) (cdr *form*))
  3611.                         ; normaler Aufruf globaler Funktion
  3612.                         (c-GLOBAL-FUNCTION-CALL fun)
  3613.                 ) ) ) )
  3614.                 (case a
  3615.                   (SYSTEM::MACRO ; lokaler Macro
  3616.                     (c-form (macroexpand-1 *form* (vector *venv* *fenv*))) ; -> expandieren
  3617.                   )
  3618.                   (GLOBAL ; Funktion im Interpreter-Environment %fenv% gefunden
  3619.                     ; (c-form `(SYS::%FUNCALL (FUNCTION ,fun) ,@(cdr *form*)))
  3620.                     (c-FUNCALL-NOTINLINE `(FUNCTION ,fun) (cdr *form*))
  3621.                   )
  3622.                   (LOCAL ; lokale Funktion (in *fenv* gefunden)
  3623.                     ; (c-form `(SYS::%FUNCALL (FUNCTION ,fun) ,@(cdr *form*)))
  3624.                     (c-LOCAL-FUNCTION-CALL fun c (cdr *form*))
  3625.                   )
  3626.                   (t (compiler-error 'c-form))
  3627.             ) ) )
  3628.             (if (and (consp fun) (eq (car fun) 'LAMBDA))
  3629.               (c-form `(SYS::%FUNCALL (FUNCTION ,fun) ,@(cdr *form*)))
  3630.               #| nicht: (c-LAMBDA-FUNCTION-CALL fun (cdr *form*)) |#
  3631.               (c-error (DEUTSCH "Das ist nicht der Name einer Funktion: ~S"
  3632.                         ENGLISH "Not the name of a function: ~S"
  3633.                         FRANCAIS "Ceci n'est pas le nom d'une fonction : ~S")
  3634.                        fun
  3635.     ) ) ) ) ) )
  3636.   ))
  3637.   #+COMPILER-DEBUG (setf (anode-source anode) *form*)
  3638.   ; Falls keine Werte gebraucht werden und keine Seiteneffekte produziert
  3639.   ; werden, kann der dazugeh÷rige Code ganz gestrichen werden:
  3640.   (when (and (null *for-value*) (null (cdr (anode-seclass anode))))
  3641.     (setf (anode-code anode) '())
  3642.     (setf (anode-seclass anode) '(NIL . NIL))
  3643.   )
  3644.   anode
  3645. ))
  3646.  
  3647. ; macroexpandiere eine Form.
  3648. ; Das ist genau das, was c-form spΣter sowieso macht.
  3649. ; (c-form (macroexpand-form form)) == (c-form form).
  3650. (defun macroexpand-form (form)
  3651.   ; Der Unterschied zu (values (macroexpand form (vector *venv* *fenv*)))
  3652.   ; ist, da▀ wir hier Macros, die in c-form-table aufgefⁿhrt sind, nicht
  3653.   ; als Macros expandieren.
  3654.   (tagbody
  3655.     reexpand
  3656.     (if (atom form)
  3657.       (if (symbolp form)
  3658.         (multiple-value-bind (macrop expansion) (venv-search-macro form *venv*)
  3659.           (if macrop
  3660.             (progn (setq form expansion) (go reexpand))
  3661.             (go done)
  3662.         ) )
  3663.         (go done)
  3664.       )
  3665.       (let ((fun (first form)))
  3666.         (if (function-name-p fun)
  3667.           (let ((a (fenv-search fun)))
  3668.             (if (or (and (null a)
  3669.                          ; nicht lokal definiert
  3670.                          (symbolp fun) (macro-function fun) ; globaler Macro?
  3671.                          (not (gethash fun c-form-table))
  3672.                     )
  3673.                     (eq a 'SYSTEM::MACRO) ; lokaler Macro?
  3674.                 )
  3675.               (progn
  3676.                 (setq form (macroexpand-1 form (vector *venv* *fenv*))) ; -> expandieren
  3677.                 (go reexpand)
  3678.               )
  3679.               (go done)
  3680.           ) )
  3681.           (go done)
  3682.     ) ) )
  3683.     done
  3684.     (return-from macroexpand-form form)
  3685. ) )
  3686.  
  3687. ; compiliere NIL (eine Art Notausgang)
  3688. (defun c-NIL ()
  3689.   (make-anode :type 'NIL
  3690.               :sub-anodes '()
  3691.               :seclass '(NIL . NIL)
  3692.               :code '((NIL)) )
  3693. )
  3694.  
  3695. ; Konstante als Form:
  3696. (defun c-CONST ()
  3697.   (make-anode :type 'const
  3698.               :sub-anodes '()
  3699.               :seclass '(NIL . NIL)
  3700.               :code `((CONST ,(new-const *form*)))
  3701. ) )
  3702.  
  3703. ; Variable als Form:
  3704. (defun c-VAR (symbol)
  3705.   ; Suche die Variable in *venv* :
  3706.   (multiple-value-bind (a b c) (venv-search symbol)
  3707.     (when (eq a 'NIL)
  3708.       (c-warn (DEUTSCH "~S ist weder deklariert noch gebunden,~@
  3709.                         behandle es als SPECIAL-deklarierte Variable."
  3710.                ENGLISH "~S is neither declared nor bound,~@
  3711.                         it will be treated as if it were declared SPECIAL."
  3712.                FRANCAIS "~S n'est ni dΘclarΘ ni liΘ,~@
  3713.                          et va Ωtre traitΘ comme Θtant dΘclarΘ SPECIAL.")
  3714.               symbol
  3715.       )
  3716.       (when *compiling-from-file*
  3717.         (pushnew symbol *unknown-free-vars* :test #'eq)
  3718.       )
  3719.       (setq a 'SPECIAL)
  3720.     )
  3721.     (case a
  3722.       (SPECIAL ; Special-Variable
  3723.         (let ((var (make-special-var symbol)))
  3724.           (make-anode
  3725.             :type 'VAR
  3726.             :sub-anodes '()
  3727.             :seclass (cons
  3728.                        (if (and *for-value* (not (var-constantp var))) (list symbol) 'NIL)
  3729.                        'NIL
  3730.                      )
  3731.             :code (if *for-value*
  3732.                     (if (var-constantp var)
  3733.                       `((CONST ,(make-const
  3734.                                   :horizont (if (keywordp symbol) ':value ':all) ; Keywords braucht man nicht in #.-Syntax
  3735.                                   :value (c-constant-value symbol)
  3736.                                   :form symbol
  3737.                        ))       )
  3738.                       `((GETVALUE ,symbol))
  3739.                     )
  3740.                     '()
  3741.       ) ) )       )
  3742.       (LOCAL ; interpretativ lexikalisch
  3743.         (make-anode
  3744.           :type 'VAR
  3745.           :sub-anodes '()
  3746.           :seclass (cons (if *for-value* 'T 'NIL) 'NIL)
  3747.           :code (if *for-value*
  3748.                   `((CONST ,(new-const b)) ; Vektor
  3749.                     (PUSH)
  3750.                     (CONST ,(new-const c)) ; Index
  3751.                     (SVREF)
  3752.                    )
  3753.                   '()
  3754.       ) )       )
  3755.       ((T) ; lexikalisch in Stack oder Closure
  3756.         (let* ((var b)
  3757.                (get-anode
  3758.                  (make-anode
  3759.                    :type 'VAR
  3760.                    :sub-anodes '()
  3761.                    :seclass (cons (if *for-value* (list var) 'NIL) 'NIL)
  3762.                    :code (if *for-value*
  3763.                            `((GET ,var ,*venvc* ,*stackz*))
  3764.                            '()
  3765.               )) )       )
  3766.           (push get-anode (var-usedp var))
  3767.           (when (and *for-value* (not *no-code*))
  3768.             (setf (var-really-usedp var) t)
  3769.             (unless (eq (stackz-fun (var-stackz var)) *func*)
  3770.               (setf (var-closurep var) t)
  3771.             )
  3772.             (when (var-closurep var)
  3773.               ; aktiviere Venvconst in allen dazwischenliegenden Funktionen
  3774.               (do ((venvc *venvc* (cdr venvc)))
  3775.                   ((null venvc) (compiler-error 'c-VAR "INVISIBLE"))
  3776.                 (when (eq venvc (var-venvc var)) (return))
  3777.                 (when (fnode-p (car venvc))
  3778.                   (setf (fnode-Venvconst (car venvc)) t)
  3779.           ) ) ) )
  3780.           get-anode
  3781.       ) )
  3782.       (t (compiler-error 'c-VAR 'venv-search))
  3783. ) ) )
  3784.  
  3785. ; Variablenzuweisung:
  3786. (defun c-VARSET (symbol value-anode for-value)
  3787.   ; Suche die Variable in *venv* :
  3788.   (multiple-value-bind (a b c) (venv-search symbol)
  3789.     (when (eq a 'NIL)
  3790.       (c-warn (DEUTSCH "~S ist weder deklariert noch gebunden,~@
  3791.                         behandle es als SPECIAL-deklarierte Variable."
  3792.                ENGLISH "~S is neither declared nor bound,~@
  3793.                         it will be treated as if it were declared SPECIAL."
  3794.                FRANCAIS "~S n'est ni dΘclarΘ ni liΘ,~@
  3795.                          et va Ωtre traitΘ comme Θtant dΘclarΘ SPECIAL.")
  3796.               symbol
  3797.       )
  3798.       (setq a 'SPECIAL)
  3799.     )
  3800.     (case a
  3801.       (SPECIAL ; Special-Variable
  3802.         (let ((var (make-special-var symbol)))
  3803.           (make-anode :type 'VARSET
  3804.                       :sub-anodes '()
  3805.                       :seclass (cons
  3806.                                  'NIL
  3807.                                  (if (var-constantp var) 'NIL (list symbol))
  3808.                                )
  3809.                       :code (if (var-constantp var)
  3810.                               (progn
  3811.                                 (c-warn (DEUTSCH "Der Konstante ~S kann nicht zugewiesen werden.~@
  3812.                                                   Die Zuweisung wird ignoriert."
  3813.                                          ENGLISH "The constant ~S may not be assigned to.~@
  3814.                                                   The assignment will be ignored."
  3815.                                          FRANCAIS "Rien ne peut Ωtre assignΘ α la constante ~S.~@
  3816.                                                    L'assignation est ignorΘe.")
  3817.                                         symbol
  3818.                                 )
  3819.                                 '((VALUES1))
  3820.                               )
  3821.                               `((SETVALUE , symbol))
  3822.       ) ) )                 )
  3823.       (LOCAL ; interpretativ lexikalisch
  3824.         (make-anode :type 'VARSET
  3825.                     :sub-anodes '()
  3826.                     :seclass (cons 'NIL 'T)
  3827.                     :code `((PUSH)
  3828.                             (CONST ,(new-const b)) ; Vektor
  3829.                             (PUSH)
  3830.                             (CONST ,(new-const c)) ; Index
  3831.                             (SVSET)
  3832.       ) )                  )
  3833.       ((T) ; lexikalisch in Stack oder Closure
  3834.         (let* ((var b)
  3835.                (set-anode
  3836.                  (make-anode :type 'VARSET
  3837.                              :sub-anodes '()
  3838.                              :seclass (cons 'NIL (list var))
  3839.                              :code `((SET ,var ,*venvc* ,*stackz*))
  3840.               )) )
  3841.           (unless (var-usedp var) (setf (var-usedp var) t)) ; Zuweisung "benutzt" die Variable
  3842.           (unless *no-code*
  3843.             (setf (var-constantp var) nil) ; nicht mehr konstant wegen Zuweisung
  3844.             (push (list* value-anode set-anode for-value) (var-modified-list var))
  3845.             (unless (eq (stackz-fun (var-stackz var)) *func*)
  3846.               (setf (var-closurep var) t)
  3847.               ; aktiviere Venvconst in allen dazwischenliegenden Funktionen
  3848.               (do ((venvc *venvc* (cdr venvc)))
  3849.                   ((null venvc) (compiler-error 'c-VARSET "INVISIBLE"))
  3850.                 (when (eq venvc (var-venvc var)) (return))
  3851.                 (when (fnode-p (car venvc))
  3852.                   (setf (fnode-Venvconst (car venvc)) t)
  3853.             ) ) )
  3854.             ; Das Ersetzen einer Variablen innervar durch var ist dann
  3855.             ; nicht erlaubt, wenn wΣhrend der Existenzdauer von innervar
  3856.             ; an var ein Wert zugewiesen wird.
  3857.             (setf (var-replaceable-list var)
  3858.               (delete-if #'(lambda (innervar-info) ; innervar gerade aktiv?
  3859.                              (let ((innervar (first innervar-info)))
  3860.                                (tailp (var-stackz innervar) *stackz*)
  3861.                            ) )
  3862.                          (var-replaceable-list var)
  3863.             ) )
  3864.           )
  3865.           set-anode
  3866.       ) )
  3867.       (t (compiler-error 'c-VARSET 'venv-search))
  3868. ) ) )
  3869.  
  3870. ;; Funktionsaufrufe, bei denen die Funktion ein Symbol oder (SETF symbol) ist:
  3871.  
  3872. (defun make-funname-const (name)
  3873.   (if (atom name)
  3874.     (new-const name)
  3875.     (let ((symbol (second name)))
  3876.       (make-const :horizont ':all
  3877.                   :value (system::get-setf-symbol symbol)
  3878.                   :form `(SYSTEM::GET-SETF-SYMBOL ',symbol)
  3879. ) ) ) )
  3880.  
  3881. ; Global function call, normal (notinline): (fun {form}*)
  3882. (defun c-NORMAL-FUNCTION-CALL (fun) ; fun ist ein Symbol oder (SETF symbol)
  3883.   (test-list *form* 1)
  3884.   (let* ((n (length (cdr *form*)))
  3885.          #+COMPILER-DEBUG (oldstackz *stackz*)
  3886.          (*stackz* *stackz*))
  3887.     (do ((formlist (cdr *form*))
  3888.          #+COMPILER-DEBUG (anodelist '())
  3889.          (codelist (list '(CALLP))))
  3890.         ((null formlist)
  3891.          (push
  3892.            `(,@(case n
  3893.                  (0 `(CALL0)) (1 `(CALL1)) (2 `(CALL2)) (t `(CALL ,n))
  3894.                )
  3895.              ,(make-funname-const fun)
  3896.             )
  3897.            codelist
  3898.          )
  3899.          (make-anode
  3900.            :type 'CALL
  3901.            :sub-anodes (nreverse anodelist)
  3902.            :seclass '(T . T)
  3903.            :code (nreverse codelist)
  3904.            :stackz oldstackz
  3905.         ))
  3906.       (let* ((formi (pop formlist))
  3907.              (anodei (c-form formi 'ONE)))
  3908.         #+COMPILER-DEBUG (push anodei anodelist)
  3909.         (push anodei codelist)
  3910.         (push '(PUSH) codelist)
  3911.         (push 1 *stackz*)
  3912. ) ) ) )
  3913.  
  3914. ; Liefert die Signatur einer Funktion aus dem fdescr
  3915. (defun fdescr-signature (fdescr)
  3916.   (if (cdr fdescr)
  3917.     (if (eq (cadr fdescr) 'LABELS)
  3918.       ; bei LABELS: aus der Lambdalisten-Information
  3919.       (multiple-value-bind (reqvar  optvar optinit optsvar  restvar
  3920.                             keyflag keyword keyvar keyinit keysvar allow-other-keys
  3921.                             auxvar auxinit)
  3922.           (values-list (cddr fdescr))
  3923.         (declare (ignore optinit optsvar keyvar keyinit keysvar auxvar auxinit))
  3924.         (values (length reqvar) (length optvar)
  3925.                 (not (eql restvar 0)) keyflag
  3926.                 keyword allow-other-keys
  3927.       ) )
  3928.       ; bei GENERIC-FLET oder GENERIC-LABELS: aus der Signatur
  3929.       (values-list (cddr fdescr))
  3930.     )
  3931.     ; bei FLET oder IN-DEFUN: aus dem fnode
  3932.     (let ((fnode (car fdescr)))
  3933.       (values (fnode-req-anz fnode) (fnode-opt-anz fnode)
  3934.               (fnode-rest-flag fnode) (fnode-keyword-flag fnode)
  3935.               (fnode-keywords fnode) (fnode-allow-other-keys-flag fnode)
  3936. ) ) ) )
  3937.  
  3938. ; (test-argument-syntax args applyargs fun req opt rest-p key-p keylist allow-p)
  3939. ; ⁿberprⁿft, ob die Argumentliste args (und evtl. weitere Argumente applyargs)
  3940. ; als Argumentliste zu fun (Symbol) geeignet ist, d.h. ob sie der gegebenen
  3941. ; Spezifikation, gegeben durch req,opt,rest-p,keylist,allow-p, genⁿgt.
  3942. ; Gegebenenfalls wird eine Warnung ausgegeben.
  3943. ; Liefert:
  3944. ;   NO-KEYS           bei korrekter Syntax, ohne Keywords,
  3945. ;   STATIC-KEYS       bei korrekter Syntax mit konstanten Keywords,
  3946. ;   DYNAMIC-KEYS      bei (vermutlich) korrekter Syntax,
  3947. ;                       mit nicht-konstanten Keywords.
  3948. ;   NIL               bei fehlerhafter Syntax,
  3949. ; In den ersten beiden FΣllen ist
  3950. ; falls (not applyargs):
  3951. ;   req <= (length args) <= (req+opt oder, falls rest-p oder key-p, unendlich)
  3952. ; bzw. falls applyargs:
  3953. ;   (length args) <= (req+opt oder, falls rest-p oder key-p, unendlich).
  3954. (defun test-argument-syntax (args applyargs fun req opt rest-p key-p keylist allow-p)
  3955.   (unless (and (listp args) (null (cdr (last args))))
  3956.     (c-error (DEUTSCH "Argumentliste zu Funktion ~S ist dotted: ~S"
  3957.               ENGLISH "argument list to function ~S is dotted: ~S"
  3958.               FRANCAIS "Liste pointΘe d'arguments pour la fonction ~S : ~S")
  3959.              fun args
  3960.   ) )
  3961.   (let ((n (length args))
  3962.         (reqopt (+ req opt)))
  3963.     (unless (and (or applyargs (<= req n)) (or rest-p key-p (<= n reqopt)))
  3964.       (c-warn (DEUTSCH "~S mit ~S~:[~; oder mehr~] Argumenten aufgerufen, braucht aber ~
  3965.                         ~:[~:[~S bis ~S~;~S~]~;mindestens ~*~S~] Argumente."
  3966.                ENGLISH "~S called with ~S~:[~; or more~] arguments, but it requires ~
  3967.                         ~:[~:[from ~S to ~S~;~S~]~;at least ~*~S~] arguments."
  3968.                FRANCAIS "~S est appelΘ avec ~S~[; ou plus~] d'arguments mais a besoin ~
  3969.                          ~:[de ~:[~S α ~S~;~S~]~;d'au moins ~*~S~] arguments.")
  3970.               fun n applyargs
  3971.               (or rest-p key-p)  (eql req reqopt) req reqopt
  3972.       )
  3973.       (return-from test-argument-syntax 'NIL)
  3974.     )
  3975.     (unless key-p (return-from test-argument-syntax 'NO-KEYS))
  3976.     ; Mit Keywords.
  3977.     (when (<= n reqopt) (return-from test-argument-syntax 'STATIC-KEYS))
  3978.     (when rest-p (return-from test-argument-syntax 'DYNAMIC-KEYS))
  3979.     (setq n (- n reqopt) args (nthcdr reqopt args))
  3980.     (unless (evenp n)
  3981.       (c-warn (DEUTSCH "Keyword-Argumente zu Funktion ~S sind nicht paarig: ~S"
  3982.                ENGLISH "keyword arguments to function ~S should occur pairwise: ~S"
  3983.                FRANCAIS "Les arguments de genre mot-clΘ pour la fonction ~S ne sont pas par paires : ~S")
  3984.               fun args
  3985.       )
  3986.       (return-from test-argument-syntax 'NIL)
  3987.     )
  3988.     (do ((keyargs args (cddr keyargs))
  3989.          (allow-flag allow-p)
  3990.          (wrong-key nil)
  3991.         )
  3992.         ((null keyargs)
  3993.          (if wrong-key
  3994.            (c-error (DEUTSCH "Keyword ~S ist bei Funktion ~S nicht erlaubt.~
  3995.                               ~%Erlaubt ~:[sind nur ~{~S~#[~; und ~S~:;, ~]~}~;ist nur ~{~S~}~]."
  3996.                      ENGLISH "keyword ~S is not allowed for function ~S.~
  3997.                               ~%The only allowed keyword~:[s are ~{~S~#[~; and ~S~:;, ~]~}~; is ~{~S~}~]."
  3998.                      FRANCAIS "L'argument mot-clΘ ~S n'est pas permis pour la fonction ~S.~
  3999.                                ~%Seul~:[s sont permis ~{~S~#[~; et ~S~:;, ~]~}~; est permis ~{~S~}~].")
  4000.                     wrong-key fun (eql (length keylist) 1) keylist
  4001.            )
  4002.            'STATIC-KEYS
  4003.         ))
  4004.       (let ((key (first keyargs)))
  4005.         (unless (c-constantp key)
  4006.           (return-from test-argument-syntax 'DYNAMIC-KEYS)
  4007.         )
  4008.         (setq key (c-constant-value key))
  4009.         (unless (keywordp key)
  4010.           (c-warn (DEUTSCH "Das Argument ~S zu Funktion ~S ist kein Keyword."
  4011.                    ENGLISH "argument ~S to function ~S is not a keyword"
  4012.                    FRANCAIS "L'argument ~S pour la fonction ~S n'est pas un mot-clΘ.")
  4013.                   (first keyargs) fun
  4014.           )
  4015.           (return-from test-argument-syntax 'DYNAMIC-KEYS)
  4016.         )
  4017.         (when (eq key ':ALLOW-OTHER-KEYS)
  4018.           (unless (c-constantp (second keyargs))
  4019.             (return-from test-argument-syntax 'DYNAMIC-KEYS)
  4020.           )
  4021.           (when (c-constant-value (second keyargs)) (setq allow-flag t))
  4022.         )
  4023.         (unless (or allow-flag (member key keylist :test #'eq))
  4024.           (setq wrong-key key)
  4025.     ) ) )
  4026. ) )
  4027.  
  4028. ; (c-DIRECT-FUNCTION-CALL args applyargs fun req opt rest-p key-p keylist
  4029. ;                         subr-flag call-code-producer)
  4030. ; compiliert die Abarbeitung der Argumente fⁿr den Direktaufruf einer
  4031. ; Funktion (d.h. ohne Argument-Check zur Laufzeit).
  4032. ; (test-argument-syntax ...) mu▀ die Argumente bereits erfolgreich (d.h.
  4033. ; mit Ergebnis NO-KEYS oder STATIC-KEYS) ⁿberprⁿft haben.
  4034. ; args : Liste der Argumentformen,
  4035. ; applyargs : falls angegeben, Liste einer Form fⁿr die weiteren Argumente,
  4036. ; fun : Name der aufzurufenden Funktion (Symbol),
  4037. ; req,opt,rest-p,key-p,keylist,allow-p : Information ⁿber die Lambdaliste von fun
  4038. ; subr-flag : Flag, ob fun ein SUBR oder aber eine compilierte Closure ist,
  4039. ;             (Obacht: applyargs nur bei compilierten Closures verwenden!),
  4040. ; call-code-producer : Funktion, die den Code liefert, der am Ende anzufⁿgen
  4041. ;                      ist und den Aufruf ausfⁿhrt.
  4042. (defun c-DIRECT-FUNCTION-CALL (args applyargs fun req opt rest-p key-p keylist
  4043.                                subr-flag call-code-producer)
  4044.   (let* ((foldable nil)
  4045.          (sideeffects ; Seiteneffektklasse des Funktionsaufrufs selbst
  4046.            (if (not subr-flag)
  4047.              '(T . T) ; kein SUBR -> kann nichts aussagen
  4048.              (case fun ; fun ein SUBR
  4049.                (; Seiteneffektklasse (NIL . NIL) haben diejenigen Funktionen,
  4050.                 ; die ihre Argumente nur anschauen (Pointer, Inhalt nur bei
  4051.                 ; Zahlen oder Σhnlichen unmodifizierbaren Datenstrukturen)
  4052.                 ; und auf keine globalen Variablen zugreifen.
  4053.                 ; Eine Funktion, die, zweimal mit denselben Argumenten auf-
  4054.                 ; gerufen, stets dasselbe Ergebnis liefert (im EQL-Sinne),
  4055.                 ; erlaubt Constant-Folding: Sind alle Argumente Konstanten
  4056.                 ; und der Funktionsaufruf durchfⁿhrbar, so darf der Funktions-
  4057.                 ; aufruf durch das konstante Funktionsergebnis ersetzt werden.
  4058.                 ;
  4059.                 ; This is the list of SUBRs which have no side effects,
  4060.                 ; don't depend on global variables or such, don't even look
  4061.                 ; "into" their arguments, and are "foldable" (two calls with
  4062.                 ; identical arguments give the same result, and calls with
  4063.                 ; constant arguments can be evaluated at compile time).
  4064.                 (SYSTEM::%FUNTABREF
  4065.                  ARRAY-ELEMENT-TYPE ARRAY-RANK ADJUSTABLE-ARRAY-P
  4066.                  STANDARD-CHAR-P GRAPHIC-CHAR-P STRING-CHAR-P ALPHA-CHAR-P UPPER-CASE-P
  4067.                  LOWER-CASE-P BOTH-CASE-P DIGIT-CHAR-P ALPHANUMERICP CHAR= CHAR/= CHAR< CHAR>
  4068.                  CHAR<= CHAR>= CHAR-EQUAL CHAR-NOT-EQUAL CHAR-LESSP CHAR-GREATERP
  4069.                  CHAR-NOT-GREATERP CHAR-NOT-LESSP CHAR-CODE CHAR-BITS CHAR-FONT CODE-CHAR
  4070.                  MAKE-CHAR CHAR-UPCASE CHAR-DOWNCASE DIGIT-CHAR CHAR-INT INT-CHAR
  4071.                  CHAR-NAME CHAR-BIT
  4072.                  SPECIAL-FORM-P
  4073.                  ENDP
  4074.                  IDENTITY
  4075.                  EQ EQL CONSP ATOM SYMBOLP STRINGP NUMBERP
  4076.                  NULL NOT SYSTEM::CLOSUREP LISTP INTEGERP SYSTEM::FIXNUMP RATIONALP FLOATP
  4077.                  SYSTEM::SHORT-FLOAT-P SYSTEM::SINGLE-FLOAT-P SYSTEM::DOUBLE-FLOAT-P SYSTEM::LONG-FLOAT-P
  4078.                  REALP COMPLEXP STREAMP SYSTEM::FILE-STREAM-P SYSTEM::SYNONYM-STREAM-P
  4079.                  SYSTEM::BROADCAST-STREAM-P SYSTEM::CONCATENATED-STREAM-P SYSTEM::TWO-WAY-STREAM-P
  4080.                  SYSTEM::ECHO-STREAM-P SYSTEM::STRING-STREAM-P
  4081.                  RANDOM-STATE-P READTABLEP HASH-TABLE-P PATHNAMEP
  4082.                  HASH-TABLE-TEST
  4083.                  SYSTEM::LOGICAL-PATHNAME-P CHARACTERP FUNCTIONP PACKAGEP ARRAYP SIMPLE-ARRAY-P
  4084.                  BIT-VECTOR-P VECTORP SIMPLE-VECTOR-P SIMPLE-STRING-P SIMPLE-BIT-VECTOR-P
  4085.                  SYSTEM::SYMBOL-MACRO-P CLOS::STRUCTURE-INSTANCE-P CLOS::STD-INSTANCE-P
  4086.                  ZEROP PLUSP MINUSP ODDP EVENP = /= < > <= >= MAX MIN
  4087.                  + - * / 1+ 1- CONJUGATE GCD LCM ISQRT
  4088.                  RATIONAL RATIONALIZE NUMERATOR DENOMINATOR FLOOR CEILING TRUNCATE
  4089.                  ROUND MOD REM DECODE-FLOAT SCALE-FLOAT
  4090.                  FLOAT-RADIX FLOAT-SIGN FLOAT-DIGITS FLOAT-PRECISION INTEGER-DECODE-FLOAT
  4091.                  COMPLEX REALPART IMAGPART LOGIOR LOGXOR LOGAND LOGEQV LOGNAND LOGNOR
  4092.                  LOGANDC1 LOGANDC2 LOGORC1 LOGORC2 BOOLE LOGNOT LOGTEST LOGBITP ASH LOGCOUNT
  4093.                  INTEGER-LENGTH LDB LDB-TEST MASK-FIELD DPB DEPOSIT-FIELD ! EXQUO
  4094.                 ) ; alle diese sind SUBRs ohne Keyword-Parameter
  4095.                 (setq foldable t)
  4096.                 '(NIL . NIL)
  4097.                )
  4098.                (;
  4099.                 ; This is the list of SUBRs which have no side effects,
  4100.                 ; don't depend on global variables or such, don't even look
  4101.                 ; "into" their arguments, but are not "foldable".
  4102.                 (VECTOR MAKE-STRING
  4103.                  VALUES ; nicht foldable, um Endlosschleife zu verhindern!
  4104.                  CONS LIST LIST* MAKE-LIST ACONS
  4105.                  LISP-IMPLEMENTATION-TYPE LISP-IMPLEMENTATION-VERSION SOFTWARE-TYPE
  4106.                  SOFTWARE-VERSION
  4107.                  SYSTEM::MAKE-LOAD-TIME-EVAL SYSTEM::MAKE-SYMBOL-MACRO
  4108.                  SYMBOL-NAME
  4109.                  SYSTEM::DECIMAL-STRING
  4110.                 )
  4111.                 '(NIL . NIL)
  4112.                )
  4113.                (;
  4114.                 ; This is the list of SUBRs which have no side effects,
  4115.                 ; but depend on global variables or look "into" their arguments.
  4116.                 (SYSTEM::SUBR-INFO
  4117.                  SYSTEM::%COPY-SIMPLE-VECTOR AREF SVREF ROW-MAJOR-AREF
  4118.                  ARRAY-DIMENSION ARRAY-DIMENSIONS ARRAY-TOTAL-SIZE
  4119.                  ARRAY-IN-BOUNDS-P ARRAY-ROW-MAJOR-INDEX BIT SBIT
  4120.                  ARRAY-HAS-FILL-POINTER-P FILL-POINTER MAKE-ARRAY
  4121.                  CHARACTER CHAR SCHAR STRING= STRING/= STRING< STRING> STRING<=
  4122.                  STRING>= STRING-EQUAL STRING-NOT-EQUAL STRING-LESSP STRING-GREATERP
  4123.                  STRING-NOT-GREATERP STRING-NOT-LESSP SYSTEM::SEARCH-STRING=
  4124.                  SYSTEM::SEARCH-STRING-EQUAL SYSTEM::STRING-BOTH-TRIM STRING-UPCASE
  4125.                  STRING-DOWNCASE STRING-CAPITALIZE STRING NAME-CHAR SUBSTRING STRING-CONCAT
  4126.                  MAKE-SYMBOL SYMBOL-VALUE SYMBOL-FUNCTION BOUNDP FBOUNDP
  4127.                  VALUES-LIST MACRO-FUNCTION CONSTANTP
  4128.                  MAKE-HASH-TABLE GETHASH HASH-TABLE-COUNT HASH-TABLE-REHASH-SIZE
  4129.                  HASH-TABLE-REHASH-THRESHOLD HASH-TABLE-SIZE SYSTEM::HASH-TABLE-ITERATOR SXHASH
  4130.                  GET-MACRO-CHARACTER GET-DISPATCH-MACRO-CHARACTER SYSTEM::LINE-POSITION
  4131.                  CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR
  4132.                  CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR
  4133.                  CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR
  4134.                  LIST-LENGTH NTH FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH
  4135.                  EIGHTH NINTH TENTH REST NTHCDR LAST APPEND COPY-LIST
  4136.                  COPY-ALIST COPY-TREE REVAPPEND BUTLAST LDIFF TAILP PAIRLIS
  4137.                  GET-UNIVERSAL-TIME GET-INTERNAL-RUN-TIME
  4138.                  GET-INTERNAL-REAL-TIME SYSTEM::%%TIME
  4139.                  FIND-PACKAGE PACKAGE-NAME PACKAGE-NICKNAMES PACKAGE-USE-LIST
  4140.                  PACKAGE-USED-BY-LIST PACKAGE-SHADOWING-SYMBOLS LIST-ALL-PACKAGES FIND-SYMBOL
  4141.                  FIND-ALL-SYMBOLS
  4142.                  PARSE-NAMESTRING PATHNAME PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY
  4143.                  PATHNAME-NAME PATHNAME-TYPE PATHNAME-VERSION FILE-NAMESTRING
  4144.                  DIRECTORY-NAMESTRING HOST-NAMESTRING MERGE-PATHNAMES ENOUGH-NAMESTRING
  4145.                  MAKE-PATHNAME NAMESTRING TRUENAME PROBE-FILE DIRECTORY FILE-WRITE-DATE
  4146.                  FILE-AUTHOR
  4147.                  EQUAL EQUALP COMPILED-FUNCTION-P CLOS::GENERIC-FUNCTION-P COMMONP
  4148.                  TYPE-OF CLOS::CLASS-P CLOS:CLASS-OF COERCE
  4149.                  SYSTEM::%RECORD-REF SYSTEM::%RECORD-LENGTH SYSTEM::%STRUCTURE-REF SYSTEM::%MAKE-STRUCTURE
  4150.                  SYSTEM::%COPY-STRUCTURE SYSTEM::%STRUCTURE-TYPE-P SYSTEM::CLOSURE-NAME
  4151.                  SYSTEM::CLOSURE-CODEVEC SYSTEM::CLOSURE-CONSTS SYSTEM::MAKE-CODE-VECTOR
  4152.                  SYSTEM::%MAKE-CLOSURE CLOS::%ALLOCATE-INSTANCE CLOS:SLOT-EXISTS-P
  4153.                  SYSTEM::SEQUENCEP ELT SUBSEQ COPY-SEQ LENGTH REVERSE CONCATENATE
  4154.                  MAKE-SYNONYM-STREAM SYNONYM-STREAM-SYMBOL MAKE-BROADCAST-STREAM
  4155.                  BROADCAST-STREAM-STREAMS MAKE-CONCATENATED-STREAM
  4156.                  CONCATENATED-STREAM-STREAMS MAKE-TWO-WAY-STREAM
  4157.                  TWO-WAY-STREAM-INPUT-STREAM TWO-WAY-STREAM-OUTPUT-STREAM
  4158.                  MAKE-ECHO-STREAM ECHO-STREAM-INPUT-STREAM
  4159.                  ECHO-STREAM-OUTPUT-STREAM MAKE-STRING-INPUT-STREAM
  4160.                  SYSTEM::STRING-INPUT-STREAM-INDEX MAKE-STRING-OUTPUT-STREAM
  4161.                  SYSTEM::MAKE-STRING-PUSH-STREAM MAKE-BUFFERED-INPUT-STREAM
  4162.                  MAKE-BUFFERED-OUTPUT-STREAM OPEN-STREAM-P INPUT-STREAM-P
  4163.                  OUTPUT-STREAM-P STREAM-ELEMENT-TYPE FILE-LENGTH
  4164.                  GET GETF GET-PROPERTIES SYMBOL-PACKAGE SYMBOL-PLIST KEYWORDP
  4165.                  SYSTEM::SPECIAL-VARIABLE-P GENSYM
  4166.                  FFLOOR FCEILING FTRUNCATE FROUND
  4167.                  EXP EXPT LOG SQRT ABS PHASE SIGNUM SIN COS TAN CIS ASIN ACOS ATAN
  4168.                  SINH COSH TANH ASINH ACOSH ATANH FLOAT BYTE BYTE-SIZE BYTE-POSITION
  4169.                  SYSTEM::LOG2 SYSTEM::LOG10
  4170.                 )
  4171.                 '(T . NIL)
  4172.                )
  4173.                ; All other SUBRs (which may have side effects) are subsumed here.
  4174.                (t '(T . T)) ; vielleicht Seiteneffekte
  4175.         )) ) )
  4176.     (if (and (null *for-value*) (null (cdr sideeffects)))
  4177.       ; Brauche die Funktion nicht aufzurufen, nur die Argumente auswerten
  4178.       (progn
  4179.         (let ((*no-code* t) (*for-value* 'NIL))
  4180.           (funcall call-code-producer)
  4181.         )
  4182.         (c-form `(PROGN ,@args ,@applyargs))
  4183.       )
  4184.       (let ((n (length args))
  4185.             (reqopt (+ req opt))
  4186.             (seclass sideeffects)
  4187.             (codelist '()))
  4188.         (let ((*stackz* *stackz*))
  4189.           ; required und angegebene optionale Parameter:
  4190.           (dotimes (i (min n reqopt))
  4191.             (let* ((formi (pop args))
  4192.                    (anodei (c-form formi 'ONE)))
  4193.               (seclass-or-f seclass anodei)
  4194.               (push anodei codelist)
  4195.             )
  4196.             (push '(PUSH) codelist)
  4197.             (push 1 *stackz*)
  4198.           )
  4199.           (if applyargs
  4200.             (progn
  4201.               (when subr-flag (compiler-error 'c-DIRECT-FUNCTION-CALL "APPLY-SUBR"))
  4202.               (when key-p (compiler-error 'c-DIRECT-FUNCTION-CALL "APPLY-KEY"))
  4203.               (if (>= reqopt n)
  4204.                 ; fehlende optionale Parameter werden aus der Liste initialisiert:
  4205.                 (let* ((anz (- reqopt n))
  4206.                        (anode1 (c-form (first applyargs) 'ONE))
  4207.                        (anode2 (progn
  4208.                                  (push (if rest-p (+ anz 1) anz) *stackz*)
  4209.                                  (c-unlist rest-p anz (min opt anz))
  4210.                       ))       )
  4211.                   (seclass-or-f seclass anode1)
  4212.                   (push anode1 codelist)
  4213.                   (seclass-or-f seclass anode2)
  4214.                   (push anode2 codelist)
  4215.                 )
  4216.                 ; n > reqopt, impliziert rest-p.
  4217.                 ; ▄bergabe von restlichen Argumenten an eine compilierte Closure:
  4218.                 ; als Liste.
  4219.                 ; Liste aus allen weiteren Argumenten:
  4220.                 (progn
  4221.                   (let ((*stackz* *stackz*)
  4222.                         (rest-args args))
  4223.                     (loop
  4224.                       (when (null rest-args) (return))
  4225.                       (let ((anode (c-form (pop rest-args) 'ONE)))
  4226.                         (seclass-or-f seclass anode)
  4227.                         (push anode codelist)
  4228.                       )
  4229.                       (push '(PUSH) codelist)
  4230.                       (push 1 *stackz*)
  4231.                     )
  4232.                     (let ((anode (c-form (first applyargs) 'ONE)))
  4233.                       (seclass-or-f seclass anode)
  4234.                       (push anode codelist)
  4235.                     )
  4236.                     (push `(LIST* ,(- n reqopt)) codelist)
  4237.                   )
  4238.                   (push '(PUSH) codelist)
  4239.                   (push 1 *stackz*)
  4240.             ) ) )
  4241.             (progn
  4242.               ; fehlende optionale Parameter werden mit #<UNBOUND> initialisiert:
  4243.               (when (> reqopt n)
  4244.                 (let ((anz (- reqopt n)))
  4245.                   (push `(PUSH-UNBOUND ,anz) codelist)
  4246.                   (push anz *stackz*)
  4247.               ) )
  4248.               ; &rest-Parameter:
  4249.               (when rest-p
  4250.                 (if subr-flag
  4251.                   ; ▄bergabe von restlichen Argumenten an ein SUBR: einzeln
  4252.                   (loop
  4253.                     (when (null args) (return))
  4254.                     (let ((anode (c-form (pop args) 'ONE)))
  4255.                       (seclass-or-f seclass anode)
  4256.                       (push anode codelist)
  4257.                     )
  4258.                     (push '(PUSH) codelist)
  4259.                     (push 1 *stackz*)
  4260.                   )
  4261.                   ; ▄bergabe von restlichen Argumenten an eine compilierte Closure:
  4262.                   ; als Liste
  4263.                   (if (null args)
  4264.                     ; leere Liste
  4265.                     (progn
  4266.                       (push '(NIL) codelist)
  4267.                       (push '(PUSH) codelist)
  4268.                       (push 1 *stackz*)
  4269.                     )
  4270.                     ; Liste aus allen weiteren Argumenten:
  4271.                     (progn
  4272.                       (let ((*stackz* *stackz*)
  4273.                             (rest-args args))
  4274.                         (loop
  4275.                           (when (null rest-args) (return))
  4276.                           (let ((anode (c-form (pop rest-args) 'ONE)))
  4277.                             (seclass-or-f seclass anode)
  4278.                             (push anode codelist)
  4279.                           )
  4280.                           (push '(PUSH) codelist)
  4281.                           (push 1 *stackz*)
  4282.                         )
  4283.                         (push `(LIST ,(- n reqopt)) codelist)
  4284.                       )
  4285.                       (push '(PUSH) codelist)
  4286.                       (push 1 *stackz*)
  4287.             ) ) ) ) )
  4288.           )
  4289.           ; &key-Parameter:
  4290.           (when key-p
  4291.             ; Nur dann gleichzeitig rest-p und key-p, wenn n <= reqopt, da
  4292.             ; test-argument-syntax (ergab STATIC-KEYS) den anderen Fall
  4293.             ; bereits ausgeschlossen hat.
  4294.             (let ((keyanz (length keylist)))
  4295.               ; Erst alle Keys mit #<UNBOUND> vorbelegen, dann die Argumente
  4296.               ; in der angegebenen Reihenfolge auswerten und zuordnen?
  4297.               ; Das ist uns zu einfach. Wir lassen die Argumente kommutieren,
  4298.               ; damit m÷glichst viele der (STORE ...) durch (PUSH) ersetzt
  4299.               ; werden k÷nnen: Die Argumente zu den ersten Keys werden nach
  4300.               ; M÷glichkeit zuerst ausgewertet, die zu den letzten Keys
  4301.               ; zuletzt. Wir lassen es allerdings bei einem einzigen
  4302.               ; (PUSH-UNBOUND ...).
  4303.               (let* ((key-positions ; Liste von Tripeln (key stack-depth free-p),
  4304.                                     ; wobei stack-depth = keyanz-1...0 lΣuft und
  4305.                                     ; free-p angibt, ob der Slot schon gefⁿllt ist.
  4306.                        (let ((i keyanz))
  4307.                          (mapcar #'(lambda (key) (list key (decf i) t)) keylist)
  4308.                      ) )
  4309.                      (anodes ; Liste von Quadrupeln
  4310.                              ; (needed key-position anode stackz), wobei
  4311.                              ; key-position die stack-depth des Keyword-Slots
  4312.                              ; oder NIL ist, anode der Anode zu diesem Argument.
  4313.                              ; Die Liste wird in derselben Reihenfolge gehalten,
  4314.                              ; wie sie die Argumentliste vorgibt.
  4315.                              ; Ausnahme: needed = NIL bei anodes, deren
  4316.                              ; Berechnung man vorgezogen oder verschoben hat.
  4317.                        (let ((L '()))
  4318.                          (loop
  4319.                            (when (null args) (return))
  4320.                            (let* ((key (c-constant-value (pop args)))
  4321.                                   (tripel (assoc key key-positions :test #'eq)) ; kann =NIL sein!
  4322.                                   (for-value (third tripel))
  4323.                                   (arg (pop args)))
  4324.                              ; for-value /= NIL: Existentes Keyword, und der Slot ist noch leer
  4325.                              ; for-value = NIL: ALLOW-erlaubtes Keyword oder Slot schon gefⁿllt
  4326.                              (let* ((*stackz* (cons 0 *stackz*)) ; 0 wird spΣter ersetzt
  4327.                                     (anode (c-form arg (if for-value 'ONE 'NIL))))
  4328.                                (seclass-or-f seclass anode)
  4329.                                (push (list t (second tripel) anode *stackz*) L)
  4330.                              )
  4331.                              (setf (third tripel) nil)
  4332.                          ) )
  4333.                          (nreverse L)
  4334.                     )) )
  4335.                 (let ((depth1 0)
  4336.                       (depth2 0)
  4337.                       (codelist-from-end '()))
  4338.                   ; M÷glichst viel nach vorne ziehen:
  4339.                   (do ((anodesr anodes (cdr anodesr)))
  4340.                       ((null anodesr))
  4341.                     (let ((anodeetc (car anodesr))) ; nΣchstes Quadrupel
  4342.                       (when (first anodeetc) ; noch was zu tun?
  4343.                         (if (and
  4344.                               (or ; kein Keyword, d.h. kein (STORE ...) n÷tig?
  4345.                                   (null (second anodeetc))
  4346.                                   ; oberstes Keyword?
  4347.                                   (= (second anodeetc) (- keyanz depth1 1))
  4348.                               )
  4349.                               ; kommutiert anodeetc mit allen vorigen anodes?
  4350.                               (let ((anode (third anodeetc)))
  4351.                                 (do ((anodesr2 anodes (cdr anodesr2)))
  4352.                                     ((eq anodesr2 anodesr) t)
  4353.                                   (unless (anodes-commute anode (third (car anodesr2)))
  4354.                                     (return nil)
  4355.                               ) ) )
  4356.                             )
  4357.                           ; vorziehen:
  4358.                           (progn
  4359.                             (setf (first (fourth anodeetc)) depth1) ; korrekte Stacktiefe
  4360.                             (push (third anodeetc) codelist) ; in die Codeliste
  4361.                             (when (second anodeetc)
  4362.                               (push '(PUSH) codelist)
  4363.                               (incf depth1)
  4364.                             )
  4365.                             (setf (first anodeetc) nil) ; diesen brauchen wir nicht mehr
  4366.                           )
  4367.                           ; sonst machen wir nichts.
  4368.                   ) ) ) )
  4369.                   ; M÷glichst viel nach hinten ziehen:
  4370.                   (setq anodes (nreverse anodes))
  4371.                   (do ((anodesr anodes (cdr anodesr)))
  4372.                       ((null anodesr))
  4373.                     (let ((anodeetc (car anodesr))) ; nΣchstes Quadrupel
  4374.                       (when (first anodeetc) ; noch was zu tun?
  4375.                         (if (and
  4376.                               (or ; kein Keyword, d.h. kein (STORE ...) n÷tig?
  4377.                                   (null (second anodeetc))
  4378.                                   ; unterstes Keyword?
  4379.                                   (= (second anodeetc) depth2)
  4380.                               )
  4381.                               ; kommutiert anodeetc mit allen spΣteren anodes?
  4382.                               (let ((anode (third anodeetc)))
  4383.                                 (do ((anodesr2 anodes (cdr anodesr2)))
  4384.                                     ((eq anodesr2 anodesr) t)
  4385.                                   (unless (anodes-commute anode (third (car anodesr2)))
  4386.                                     (return nil)
  4387.                               ) ) )
  4388.                             )
  4389.                           ; ans Ende verschieben:
  4390.                           (progn
  4391.                             (when (second anodeetc)
  4392.                               (push '(PUSH) codelist-from-end)
  4393.                               (incf depth2)
  4394.                             )
  4395.                             (setf (first (fourth anodeetc)) (- keyanz depth2)) ; korrekte Stacktiefe
  4396.                             (push (third anodeetc) codelist-from-end) ; in die Codeliste
  4397.                             (setf (first anodeetc) nil) ; diesen brauchen wir nicht mehr
  4398.                           )
  4399.                           ; sonst machen wir nichts.
  4400.                   ) ) ) )
  4401.                   (setq anodes (nreverse anodes))
  4402.                   (let ((depth-now (- keyanz depth2))) ; codelist-from-end erniedrigt den Stack um depth2
  4403.                     (when (> depth-now depth1)
  4404.                       (push `(PUSH-UNBOUND ,(- depth-now depth1)) codelist)
  4405.                     )
  4406.                     ; In codelist herrscht jetzt Stacktiefe depth-now.
  4407.                     (dolist (anodeetc anodes)
  4408.                       (when (first anodeetc)
  4409.                         (setf (first (fourth anodeetc)) depth-now) ; korrekte Stacktiefe
  4410.                         (push (third anodeetc) codelist)
  4411.                         (when (second anodeetc)
  4412.                           (push `(STORE ,(- (second anodeetc) depth2)) codelist)
  4413.                   ) ) ) )
  4414.                   ; Nun codelist-from-end:
  4415.                   (setq codelist (nreconc codelist-from-end codelist))
  4416.               ) )
  4417.               ; Jetzt sind alle Key-Argumente auf dem Stack.
  4418.               (push keyanz *stackz*)
  4419.           ) )
  4420.           (setq codelist (nreconc codelist (funcall call-code-producer)))
  4421.         )
  4422.         ; Constant-Folding: Ist fun foldable (also subr-flag = T und
  4423.         ; key-flag = NIL) und besteht codelist au▀er den (PUSH)s und dem
  4424.         ; Call-Code am Schlu▀ nur aus Anodes mit code = ((CONST ...)) ?
  4425.         (when (and foldable
  4426.                    (every #'(lambda (code)
  4427.                               (or (not (anode-p code)) (anode-constantp code))
  4428.                             )
  4429.                           codelist
  4430.               )    )
  4431.           ; Funktion aufzurufen versuchen:
  4432.           (let ((args (let ((L '())) ; Liste der (konstanten) Argumente
  4433.                         (dolist (code codelist)
  4434.                           (when (anode-p code)
  4435.                             (push (anode-constant-value code) L)
  4436.                         ) )
  4437.                         (nreverse L)
  4438.                 )     )
  4439.                 resulting-values)
  4440.             (when (block try-eval
  4441.                     (setq resulting-values
  4442.                       (let ((*error-handler*
  4443.                               #'(lambda (&rest error-args)
  4444.                                   (declare (ignore error-args))
  4445.                                   (return-from try-eval nil)
  4446.                            ))   )
  4447.                         (multiple-value-list (apply fun args))
  4448.                     ) )
  4449.                     t
  4450.                   )
  4451.               ; Funktion erfolgreich aufgerufen, Constant-Folding durchfⁿhren:
  4452.               (return-from c-DIRECT-FUNCTION-CALL
  4453.                 (c-GLOBAL-FUNCTION-CALL-form
  4454.                   `(VALUES ,@(mapcar #'(lambda (x) `(QUOTE ,x)) resulting-values))
  4455.         ) ) ) ) )
  4456.         (make-anode
  4457.           :type `(DIRECT-CALL ,fun)
  4458.           :sub-anodes (remove-if-not #'anode-p codelist)
  4459.           :seclass seclass
  4460.           :code codelist
  4461.         )
  4462. ) ) ) )
  4463. (defun c-unlist (rest-p n m)
  4464.   (if rest-p
  4465.     (if (eql n 0)
  4466.       (make-anode :type 'UNLIST*
  4467.                   :sub-anodes '()
  4468.                   :seclass '(NIL . NIL)
  4469.                   :code '((PUSH))
  4470.       )
  4471.       (make-anode :type 'UNLIST*
  4472.                   :sub-anodes '()
  4473.                   :seclass '(T . T) ; kann Error melden
  4474.                   :code `((UNLIST* ,n ,m))
  4475.     ) )
  4476.     (make-anode :type 'UNLIST
  4477.                 :sub-anodes '()
  4478.                 :seclass '(T . T) ; kann Error melden
  4479.                 :code `((UNLIST ,n ,m))
  4480. ) ) )
  4481. (defun cclosure-call-code-producer (fun fnode req opt rest-flag key-flag keylist)
  4482.   (if (eq fnode *func*)
  4483.     ; rekursiver Aufruf der eigenen Funktion
  4484.     (let ((call-code
  4485.             `((JSR ,(+ req opt (if rest-flag 1 0) (length keylist)) ; Zahl der Stack-EintrΣge
  4486.                    ,*func-start-label*
  4487.              ))
  4488.          ))
  4489.       #'(lambda () call-code)
  4490.     )
  4491.     ; eine andere Cclosure aufrufen
  4492.     #'(lambda ()
  4493.         (list
  4494.           (c-form `(FUNCTION ,fun) 'ONE)
  4495.           (if key-flag '(CALLCKEY) '(CALLC))
  4496.       ) )
  4497. ) )
  4498.  
  4499. ; Global function call: (fun {form}*)
  4500. (defun c-GLOBAL-FUNCTION-CALL-form (*form*)
  4501.   (c-GLOBAL-FUNCTION-CALL (first *form*))
  4502. )
  4503. (defun c-GLOBAL-FUNCTION-CALL (fun) ; fun ist ein Symbol oder (SETF symbol)
  4504.   (test-list *form* 1)
  4505.   (when *compiling-from-file* ; von COMPILE-FILE aufgerufen?
  4506.     (unless (or (fboundp fun) (member fun *known-functions* :test #'equal))
  4507.       (pushnew fun *unknown-functions* :test #'equal)
  4508.     )
  4509.     ; PROCLAIM-Deklarationen zur Kenntnis nehmen:
  4510.     (when (and (eq fun 'PROCLAIM) (= (length *form*) 2))
  4511.       (let ((h (second *form*)))
  4512.         (when (c-constantp h)
  4513.           (c-form
  4514.             `(EVAL-WHEN (COMPILE) (c-PROCLAIM ',(c-constant-value h)))
  4515.     ) ) ) )
  4516.     ; Modul-Anforderungen zur Kenntnis nehmen:
  4517.     (when (and (memq fun '(PROVIDE REQUIRE))
  4518.                (every #'c-constantp (rest *form*))
  4519.           )
  4520.       (c-form
  4521.         `(EVAL-WHEN (COMPILE)
  4522.            (,(case fun
  4523.                (PROVIDE 'c-PROVIDE) ; c-PROVIDE statt PROVIDE
  4524.                (REQUIRE 'c-REQUIRE) ; c-REQUIRE statt REQUIRE
  4525.              )
  4526.             ,@(mapcar
  4527.                 #'(lambda (x) (list 'QUOTE (c-constant-value x))) ; Argumente quotieren
  4528.                 (rest *form*)
  4529.          ) )  )
  4530.     ) )
  4531.     ; Package-Anforderungen zur Kenntnis nehmen:
  4532.     (when (and (memq fun '(MAKE-PACKAGE SYSTEM::%IN-PACKAGE IN-PACKAGE
  4533.                            SHADOW SHADOWING-IMPORT EXPORT UNEXPORT
  4534.                            USE-PACKAGE UNUSE-PACKAGE IMPORT
  4535.                )          )
  4536.                (every #'c-constantp (rest *form*))
  4537.           )
  4538.       (push
  4539.         `(,fun
  4540.           ,@(mapcar
  4541.               #'(lambda (x) (list 'QUOTE (c-constant-value x))) ; Argumente quotieren
  4542.               (rest *form*)
  4543.          )  )
  4544.         *package-tasks*
  4545.   ) ) )
  4546.   (let* ((args (cdr *form*)) ; Argumente
  4547.          (n (length args))) ; Anzahl der Argumente
  4548.     (if (not (declared-notinline fun)) ; darf fun INLINE genommen werden?
  4549.       (multiple-value-bind (name req opt rest-p keylist allow-p) (subr-info fun)
  4550.         ; Ist fun ein SUBR, so sollte name = fun sein, und das SUBR hat die
  4551.         ; Spezifikation req, opt, rest-p, key-p = (not (null keylist)), allow-p.
  4552.         ; Sonst ist name = NIL.
  4553.         (if (and name (eq fun name)) ; beschreibt fun ein gⁿltiges SUBR?
  4554.           (case fun
  4555.             ((CAR CDR FIRST REST NOT NULL CONS SVREF VALUES
  4556.               CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR
  4557.               CDDAR CDDDR SECOND THIRD FOURTH CAAAAR CAAADR CAADAR CAADDR
  4558.               CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR
  4559.               CDDAAR CDDADR CDDDAR CDDDDR ATOM CONSP
  4560.               VALUES-LIST SYS::%SVSTORE EQ SYMBOL-FUNCTION LIST LIST*
  4561.              )
  4562.              ; Diese hier haben keylist=NIL, allow-p=NIL und
  4563.              ; (was aber nicht verwendet wird) opt=0.
  4564.              (if (and (<= req n) (or rest-p (<= n (+ req opt))))
  4565.                ; Wir machen den Aufruf INLINE.
  4566.                (let ((sideeffects ; Seiteneffektklasse der Funktionsausfⁿhrung
  4567.                        (case fun
  4568.                          ((NOT NULL CONS VALUES ATOM CONSP EQ LIST LIST*)
  4569.                            '(NIL . NIL)
  4570.                          )
  4571.                          ((CAR CDR FIRST REST CAAR CADR
  4572.                            CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR
  4573.                            CDDDR SECOND THIRD FOURTH CAAAAR CAAADR CAADAR CAADDR
  4574.                            CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR
  4575.                            CDDAAR CDDADR CDDDAR CDDDDR VALUES-LIST
  4576.                            SVREF SYMBOL-FUNCTION
  4577.                           )
  4578.                            '(T . NIL)
  4579.                          )
  4580.                          (t '(T . T))
  4581.                     )) )
  4582.                  (if (and (null *for-value*) (null (cdr sideeffects)))
  4583.                    ; Brauche die Funktion nicht aufzurufen, nur die Argumente auswerten
  4584.                    (c-form `(PROGN ,@args))
  4585.                    (if (and (eq fun 'VALUES) (eq *for-value* 'ONE))
  4586.                      (if (= n 0) (c-NIL) (c-form `(PROG1 ,@args)))
  4587.                      (let ((seclass sideeffects)
  4588.                            (codelist '()))
  4589.                        (let ((*stackz* *stackz*))
  4590.                          ; Argumente auswerten und bis auf das letzte auf den Stack
  4591.                          ; (denn das letzte Argument wird in A0 erwartet):
  4592.                          (loop
  4593.                            (when (null args) (return))
  4594.                            (let ((anode (c-form (pop args) 'ONE)))
  4595.                              (seclass-or-f seclass anode)
  4596.                              (push anode codelist)
  4597.                            )
  4598.                            (when args ; nicht am Schlu▀
  4599.                              (push '(PUSH) codelist)
  4600.                              (push 1 *stackz*)
  4601.                          ) )
  4602.                          (setq codelist
  4603.                            (nreconc codelist
  4604.                              (case fun
  4605.                                ((CAR FIRST) '((CAR)))
  4606.                                ((CDR REST) '((CDR)))
  4607.                                (CAAR '((CAR) (CAR)))
  4608.                                ((CADR SECOND) '((CDR) (CAR)))
  4609.                                (CDAR '((CAR) (CDR)))
  4610.                                (CDDR '((CDR) (CDR)))
  4611.                                (CAAAR '((CAR) (CAR) (CAR)))
  4612.                                (CAADR '((CDR) (CAR) (CAR)))
  4613.                                (CADAR '((CAR) (CDR) (CAR)))
  4614.                                ((CADDR THIRD) '((CDR) (CDR) (CAR)))
  4615.                                (CDAAR '((CAR) (CAR) (CDR)))
  4616.                                (CDADR '((CDR) (CAR) (CDR)))
  4617.                                (CDDAR '((CAR) (CDR) (CDR)))
  4618.                                (CDDDR '((CDR) (CDR) (CDR)))
  4619.                                (CAAAAR '((CAR) (CAR) (CAR) (CAR)))
  4620.                                (CAAADR '((CDR) (CAR) (CAR) (CAR)))
  4621.                                (CAADAR '((CAR) (CDR) (CAR) (CAR)))
  4622.                                (CAADDR '((CDR) (CDR) (CAR) (CAR)))
  4623.                                (CADAAR '((CAR) (CAR) (CDR) (CAR)))
  4624.                                (CADADR '((CDR) (CAR) (CDR) (CAR)))
  4625.                                (CADDAR '((CAR) (CDR) (CDR) (CAR)))
  4626.                                ((CADDDR FOURTH) '((CDR) (CDR) (CDR) (CAR)))
  4627.                                (CDAAAR '((CAR) (CAR) (CAR) (CDR)))
  4628.                                (CDAADR '((CDR) (CAR) (CAR) (CDR)))
  4629.                                (CDADAR '((CAR) (CDR) (CAR) (CDR)))
  4630.                                (CDADDR '((CDR) (CDR) (CAR) (CDR)))
  4631.                                (CDDAAR '((CAR) (CAR) (CDR) (CDR)))
  4632.                                (CDDADR '((CDR) (CAR) (CDR) (CDR)))
  4633.                                (CDDDAR '((CAR) (CDR) (CDR) (CDR)))
  4634.                                (CDDDDR '((CDR) (CDR) (CDR) (CDR)))
  4635.                                (ATOM '((ATOM)))
  4636.                                (CONSP '((CONSP)))
  4637.                                ((NOT NULL) '((NOT)))
  4638.                                (CONS '((CONS)))
  4639.                                (SVREF '((SVREF)))
  4640.                                (SYS::%SVSTORE '((SVSET)))
  4641.                                (EQ '((EQ)))
  4642.                                (VALUES (case n
  4643.                                          (0 '((VALUES0)) )
  4644.                                          (1 '((VALUES1)) )
  4645.                                          (t `((PUSH) ; letztes Argument auch noch in den Stack
  4646.                                               (STACK-TO-MV ,n)
  4647.                                              )
  4648.                                )       ) )
  4649.                                (VALUES-LIST '((LIST-TO-MV)))
  4650.                                (SYMBOL-FUNCTION '((SYMBOL-FUNCTION)))
  4651.                                (LIST (if (plusp n)
  4652.                                        `((PUSH) (LIST ,n))
  4653.                                        '((NIL))
  4654.                                )     )
  4655.                                (LIST* (case n
  4656.                                         (1 '((VALUES1)) )
  4657.                                         (t `((LIST* ,(1- n))) )
  4658.                                )      )
  4659.                                (t (compiler-error 'c-GLOBAL-FUNCTION-CALL))
  4660.                        ) ) ) )
  4661.                        (make-anode
  4662.                          :type `(PRIMOP ,fun)
  4663.                          :sub-anodes (remove-if-not #'anode-p codelist)
  4664.                          :seclass seclass
  4665.                          :code codelist
  4666.                        )
  4667.                ) ) ) )
  4668.                ; falsche Argumentezahl -> doch nicht INLINE:
  4669.                (progn
  4670.                  (c-warn (DEUTSCH "~S mit ~S Argumenten aufgerufen, braucht aber ~
  4671.                                    ~:[~:[~S bis ~S~;~S~]~;mindestens ~*~S~] Argumente."
  4672.                           ENGLISH "~S called with ~S arguments, but it requires ~
  4673.                                    ~:[~:[from ~S to ~S~;~S~]~;at least ~*~S~] arguments."
  4674.                           FRANCAIS "~S est appelΘ avec ~S arguments mais a besoin ~
  4675.                                     ~:[de ~:[~S α ~S~;~S~]~;d'au moins ~*~S~] arguments.")
  4676.                          fun n
  4677.                          rest-p  (eql opt 0) req (+ req opt)
  4678.                  )
  4679.                  (c-NORMAL-FUNCTION-CALL fun)
  4680.             )) )
  4681.             (t ; Ist das SUBR fun in der FUNTAB enthalten?
  4682.              (let ((index (gethash fun function-codes)))
  4683.                (if index
  4684.                  (case (test-argument-syntax args nil
  4685.                                     fun req opt rest-p keylist keylist allow-p
  4686.                        )
  4687.                    ((NO-KEYS STATIC-KEYS)
  4688.                     ; korrekte Syntax, Stack-Layout zur Compilezeit vorhersehbar
  4689.                     ; -> INLINE
  4690.                     (c-DIRECT-FUNCTION-CALL
  4691.                       args nil fun req opt rest-p keylist keylist
  4692.                       t ; es handelt sich um ein SUBR
  4693.                       (let ((call-code
  4694.                               ; Aufruf mit Hilfe der FUNTAB:
  4695.                               (cons
  4696.                                 (if (not rest-p)
  4697.                                   (CALLS-code index)
  4698.                                   `(CALLSR ,(max 0 (- n req opt)) ; Bei n<req+opt kommt noch ein (PUSH-UNBOUND ...)
  4699.                                            ,(- index funtabR-index)
  4700.                                    )
  4701.                                 )
  4702.                                 (case fun
  4703.                                   (; Funktionen, die nicht zurⁿckkehren:
  4704.                                    (; control.d:
  4705.                                     SYS::DRIVER SYS::UNWIND-TO-DRIVER
  4706.                                     ; debug.d:
  4707.                                     ; SYS::REDO-EVAL-FRAME SYS::RETURN-FROM-EVAL-FRAME
  4708.                                     ; error.d:
  4709.                                     ERROR SYSTEM::ERROR-OF-TYPE INVOKE-DEBUGGER
  4710.                                    )
  4711.                                    '((BARRIER))
  4712.                                   )
  4713.                                   (t '())
  4714.                            )) ) )
  4715.                         #'(lambda () call-code)
  4716.                    )) )
  4717.                    (t (c-NORMAL-FUNCTION-CALL fun))
  4718.                  )
  4719.                  (c-NORMAL-FUNCTION-CALL fun)
  4720.           ) )) )
  4721.           (let ((inline-lambdabody
  4722.                   (or (and *compiling-from-file*
  4723.                            (cdr (assoc fun *inline-definitions* :test #'equal))
  4724.                       )
  4725.                       (get (get-funname-symbol fun) 'sys::inline-expansion)
  4726.                )) )
  4727.             (if (and #| inline-lambdabody |#
  4728.                      (consp inline-lambdabody)
  4729.                      (inline-callable-function-lambda-p `(FUNCTION (LAMBDA ,@inline-lambdabody)) n)
  4730.                 )
  4731.               ; Aufruf einer globalen Funktion INLINE m÷glich
  4732.               (c-FUNCALL-INLINE fun args nil inline-lambdabody nil)
  4733.               (c-NORMAL-FUNCTION-CALL fun)
  4734.       ) ) ) )
  4735.       (c-NORMAL-FUNCTION-CALL fun)
  4736. ) ) )
  4737.  
  4738. ; Hilfsfunktion: PROCLAIM beim Compilieren vom File, vgl. Funktion PROCLAIM
  4739. (defun c-PROCLAIM (declspec)
  4740.   (when (consp declspec)
  4741.     (case (car declspec)
  4742.       (SPECIAL
  4743.         (dolist (var (cdr declspec))
  4744.           (when (symbolp var) (pushnew var *known-special-vars* :test #'eq))
  4745.       ) )
  4746.       (INLINE
  4747.         (dolist (var (cdr declspec))
  4748.           (when (function-name-p var)
  4749.             (pushnew var *inline-functions* :test #'equal)
  4750.             (setq *notinline-functions* (delete var *notinline-functions* :test #'equal))
  4751.       ) ) )
  4752.       (NOTINLINE
  4753.         (dolist (var (cdr declspec))
  4754.           (when (function-name-p var)
  4755.             (pushnew var *notinline-functions* :test #'equal)
  4756.             (setq *inline-functions* (delete var *inline-functions* :test #'equal))
  4757.       ) ) )
  4758.       (DECLARATION
  4759.         (dolist (var (cdr declspec))
  4760.           (when (symbolp var) (pushnew var *user-declaration-types* :test #'eq))
  4761.       ) )
  4762. ) ) )
  4763.  
  4764. ; Hilfsfunktion: DEFCONSTANT beim Compilieren
  4765. (defun c-PROCLAIM-CONSTANT (symbol initial-value-form)
  4766.   (when *compiling-from-file*
  4767.     (pushnew symbol *known-special-vars* :test #'eq)
  4768.     (when (c-constantp initial-value-form)
  4769.       (push (cons symbol (c-constant-value initial-value-form))
  4770.             *constant-special-vars*
  4771. ) ) ) )
  4772.  
  4773. ; Hilfsfunktion: DEFUN beim Compilieren
  4774. (defun c-DEFUN (symbol &optional lambdabody)
  4775.   (when *compiling* ; c-DEFUN kann auch vom Expander aus aufgerufen werden!
  4776.     (when *compiling-from-file*
  4777.       (pushnew symbol *known-functions* :test #'equal)
  4778.       (when lambdabody ; Lambdabody angegeben ->
  4779.         ; Funktionsdefinition erfolgt im Top-Level-Environment und ist inlinebar.
  4780.         (push (cons symbol lambdabody) *inline-definitions*)
  4781. ) ) ) )
  4782.  
  4783. ; Hilfsfunktion: PROVIDE beim Compilieren vom File, vgl. Funktion PROVIDE
  4784. (defun c-PROVIDE (module-name)
  4785.   (pushnew (string module-name) *compiled-modules* :test #'string=)
  4786. )
  4787.  
  4788. ; Hilfsfunktion: REQUIRE beim Compilieren vom File, vgl. Funktion REQUIRE
  4789. (defun c-REQUIRE (module-name &optional (pathname nil p-given))
  4790.   (unless (member (string module-name) *compiled-modules* :test #'string-equal)
  4791.     (unless p-given (setq pathname (pathname module-name)))
  4792.     (flet ((load-lib (file)
  4793.              (let* ((present-files
  4794.                       (search-file file (append *source-file-types* '(#".lib")))
  4795.                     )
  4796.                     (newest-file (first present-files)))
  4797.                ; Falls das libfile unter den gefundenen Files vorkommt
  4798.                ; und das neueste ist:
  4799.                (if (and (consp present-files)
  4800.                         (string= (pathname-type newest-file)
  4801.                                  '#,(pathname-type '#".lib")
  4802.                    )    )
  4803.                  (load newest-file :verbose nil :print nil :echo nil) ; libfile laden
  4804.                  (compile-file (or newest-file file)) ; file compilieren
  4805.           )) ) )
  4806.       (if (atom pathname) (load-lib pathname) (mapcar #'load-lib pathname))
  4807. ) ) )
  4808.  
  4809. ;;; Hilfsfunktionen fⁿr
  4810. ;;; LET/LET*/MULTIPLE-VALUE-BIND/Lambda-Ausdruck/FLET/LABELS:
  4811.  
  4812. ;; Syntaxanalyse:
  4813.  
  4814. ; analysiert eine Parameterliste von LET/LET*, liefert:
  4815. ; die Liste der Symbole,
  4816. ; die Liste der Formen.
  4817. (defun analyze-letlist (parameters)
  4818.   (do ((L parameters (cdr L))
  4819.        (symbols nil)
  4820.        (forms nil))
  4821.       ((null L) (values (nreverse symbols) (nreverse forms)))
  4822.     (cond ((symbolp (car L)) (push (car L) symbols) (push nil forms))
  4823.           ((and (consp (car L)) (symbolp (caar L))
  4824.                 (consp (cdar L)) (null (cddar L))
  4825.            )
  4826.            (push (caar L) symbols) (push (cadar L) forms)
  4827.           )
  4828.           (t (catch 'c-error
  4829.                (c-error (DEUTSCH "Falsche Syntax in LET/LET*: ~S"
  4830.                          ENGLISH "Illegal syntax in LET/LET*: ~S"
  4831.                          FRANCAIS "Mauvaise syntaxe pour LET/LET* : ~S")
  4832.                         (car L)
  4833.     )     )  ) )
  4834. ) )
  4835.  
  4836. ; analysiert eine Lambdaliste einer Funktion (CLTL S. 60), liefert 13 Werte:
  4837. ; 1. Liste der required Parameter
  4838. ; 2. Liste der optionalen Parameter
  4839. ; 3. Liste der Initformen der optionalen Parameter
  4840. ; 4. Liste der Svars zu den optionalen Parametern (0 fⁿr die fehlenden)
  4841. ; 5. Rest-Parameter oder 0
  4842. ; 6. Flag, ob Keywords erlaubt sind
  4843. ; 7. Liste der Keywords
  4844. ; 8. Liste der Keyword-Parameter
  4845. ; 9. Liste der Initformen der Keyword-Parameter
  4846. ; 10. Liste der Svars zu den Keyword-Parametern (0 fⁿr die fehlenden)
  4847. ; 11. Flag, ob andere Keywords erlaubt sind
  4848. ; 12. Liste der Aux-Variablen
  4849. ; 13. Liste der Initformen der Aux-Variablen
  4850. (defun analyze-lambdalist (lambdalist)
  4851.   (let ((L lambdalist) ; Rest der Lambdaliste
  4852.         (req nil)
  4853.         (optvar nil)
  4854.         (optinit nil)
  4855.         (optsvar nil)
  4856.         (rest 0)
  4857.         (keyflag nil)
  4858.         (keyword nil)
  4859.         (keyvar nil)
  4860.         (keyinit nil)
  4861.         (keysvar nil)
  4862.         (allow-other-keys nil)
  4863.         (auxvar nil)
  4864.         (auxinit nil))
  4865.        ; alle in umgedrehter Reihenfolge
  4866.     (macrolet ((err-illegal (item)
  4867.                  `(catch 'c-error
  4868.                     (c-error (DEUTSCH "Dieser Lambdalistenmarker ist an dieser Stelle nicht erlaubt: ~S"
  4869.                               ENGLISH "Lambda list marker ~S not allowed here."
  4870.                               FRANCAIS "Le marqueur de liste lambda ~S n'est pas permis ici.")
  4871.                              ,item
  4872.                   ) )
  4873.                )
  4874.                (err-norest ()
  4875.                  `(catch 'c-error
  4876.                     (c-error (DEUTSCH "Fehlender &REST-Parameter in der Lambdaliste: ~S"
  4877.                               ENGLISH "Missing &REST parameter in lambda list ~S"
  4878.                               FRANCAIS "Il manque le paramΦtre &REST dans la liste lambda ~S")
  4879.                              lambdalist
  4880.                   ) )
  4881.                )
  4882.                (err-superflu (item)
  4883.                  `(catch 'c-error
  4884.                     (c-error (DEUTSCH "▄berflⁿssiges Lambdalisten-Element: ~S"
  4885.                               ENGLISH "Lambda list element ~S is superfluous."
  4886.                               FRANCAIS "L'ΘlΘment de liste lambda est superflu : ~S")
  4887.                              ,item
  4888.                   ) )
  4889.               ))
  4890.       ; Required Parameter:
  4891.       (loop
  4892.         (if (atom L) (return))
  4893.         (let ((item (car L)))
  4894.           (if (symbolp item)
  4895.             (if (memq item lambda-list-keywords)
  4896.               (if (memq item '(&optional &rest &key &aux))
  4897.                 (return)
  4898.                 (err-illegal item)
  4899.               )
  4900.               (push item req)
  4901.             )
  4902.             (lambdalist-error item)
  4903.         ) )
  4904.         (setq L (cdr L))
  4905.       )
  4906.       ; Hier gilt (or (atom L) (member (car L) '(&optional &rest &key &aux))).
  4907.       ; Optionale Parameter:
  4908.       (when (and (consp L) (eq (car L) '&optional))
  4909.         (setq L (cdr L))
  4910.         (loop
  4911.           (if (atom L) (return))
  4912.           (let ((item (car L)))
  4913.             (if (symbolp item)
  4914.               (if (memq item lambda-list-keywords)
  4915.                 (if (memq item '(&rest &key &aux))
  4916.                   (return)
  4917.                   (err-illegal item)
  4918.                 )
  4919.                 (progn (push item optvar) (push nil optinit) (push 0 optsvar))
  4920.               )
  4921.               (if (and (consp item) (symbolp (car item)))
  4922.                 (if (null (cdr item))
  4923.                   (progn (push (car item) optvar) (push nil optinit) (push 0 optsvar))
  4924.                   (if (consp (cdr item))
  4925.                     (if (null (cddr item))
  4926.                       (progn (push (car item) optvar) (push (cadr item) optinit) (push 0 optsvar))
  4927.                       (if (and (consp (cddr item)) (symbolp (caddr item)) (null (cdddr item)))
  4928.                         (progn (push (car item) optvar) (push (cadr item) optinit) (push (caddr item) optsvar))
  4929.                         (lambdalist-error item)
  4930.                     ) )
  4931.                     (lambdalist-error item)
  4932.                 ) )
  4933.                 (lambdalist-error item)
  4934.           ) ) )
  4935.           (setq L (cdr L))
  4936.       ) )
  4937.       ; Hier gilt (or (atom L) (member (car L) '(&rest &key &aux))).
  4938.       ; Rest-Parameter:
  4939.       (when (and (consp L) (eq (car L) '&rest))
  4940.         (setq L (cdr L))
  4941.         (if (atom L)
  4942.           (err-norest)
  4943.           (prog ((item (car L)))
  4944.             (if (symbolp item)
  4945.               (if (memq item lambda-list-keywords)
  4946.                 (progn (err-norest) (return))
  4947.                 (setq rest item)
  4948.               )
  4949.               (lambdalist-error item)
  4950.             )
  4951.             (setq L (cdr L))
  4952.       ) ) )
  4953.       ; Vorrⁿcken bis zum nΣchsten &key oder &aux :
  4954.       (loop
  4955.         (when (atom L) (return))
  4956.         (let ((item (car L)))
  4957.           (if (memq item lambda-list-keywords)
  4958.             (if (memq item '(&key &aux))
  4959.               (return)
  4960.               (err-illegal item)
  4961.             )
  4962.             (err-superflu item)
  4963.         ) )
  4964.         (setq L (cdr L))
  4965.       )
  4966.       ; Hier gilt (or (atom L) (member (car L) '(&key &aux))).
  4967.       ; Keyword-Parameter:
  4968.       (when (and (consp L) (eq (car L) '&key))
  4969.         (setq L (cdr L))
  4970.         (setq keyflag t)
  4971.         (loop
  4972.           (if (atom L) (return))
  4973.           (let ((item (car L)))
  4974.             (if (symbolp item)
  4975.               (if (memq item lambda-list-keywords)
  4976.                 (if (memq item '(&allow-other-keys &aux))
  4977.                   (return)
  4978.                   (err-illegal item)
  4979.                 )
  4980.                 (progn
  4981.                   (push (intern (symbol-name item) *keyword-package*) keyword)
  4982.                   (push item keyvar) (push nil keyinit) (push 0 keysvar)
  4983.               ) )
  4984.               (if (and
  4985.                     (consp item)
  4986.                     (or
  4987.                       (symbolp (car item))
  4988.                       (and (consp (car item))
  4989.                            (keywordp (caar item))
  4990.                            (consp (cdar item))
  4991.                            (symbolp (cadar item))
  4992.                            (null (cddar item))
  4993.                     ) )
  4994.                     (or (null (cdr item))
  4995.                         (and (consp (cdr item))
  4996.                              (or (null (cddr item))
  4997.                                  (and (consp (cddr item)) (symbolp (caddr item)) (null (cdddr item)))
  4998.                   ) )   )    )
  4999.                 (progn
  5000.                   (if (consp (car item))
  5001.                     (progn (push (caar item) keyword) (push (cadar item) keyvar))
  5002.                     (progn (push (intern (symbol-name (car item)) *keyword-package*) keyword) (push (car item) keyvar))
  5003.                   )
  5004.                   (if (consp (cdr item))
  5005.                     (progn
  5006.                       (push (cadr item) keyinit)
  5007.                       (if (consp (cddr item))
  5008.                         (push (caddr item) keysvar)
  5009.                         (push 0 keysvar)
  5010.                     ) )
  5011.                     (progn (push nil keyinit) (push 0 keysvar))
  5012.                 ) )
  5013.                 (lambdalist-error item)
  5014.           ) ) )
  5015.           (setq L (cdr L))
  5016.         )
  5017.         ; Hier gilt (or (atom L) (member (car L) '(&allow-other-keys &aux))).
  5018.         (when (and (consp L) (eq (car L) '&allow-other-keys))
  5019.           (setq allow-other-keys t)
  5020.           (setq L (cdr L))
  5021.       ) )
  5022.       ; Vorrⁿcken bis zum nΣchsten &AUX :
  5023.       (loop
  5024.         (when (atom L) (return))
  5025.         (let ((item (car L)))
  5026.           (if (memq item lambda-list-keywords)
  5027.             (if (memq item '(&aux))
  5028.               (return)
  5029.               (err-illegal item)
  5030.             )
  5031.             (err-superflu item)
  5032.         ) )
  5033.         (setq L (cdr L))
  5034.       )
  5035.       ; Hier gilt (or (atom L) (member (car L) '(&aux))).
  5036.       ; &AUX-Variablen:
  5037.       (when (and (consp L) (eq (car L) '&aux))
  5038.         (setq L (cdr L))
  5039.         (loop
  5040.           (if (atom L) (return))
  5041.           (let ((item (car L)))
  5042.             (if (symbolp item)
  5043.               (if (memq item lambda-list-keywords)
  5044.                 (err-illegal item)
  5045.                 (progn (push item auxvar) (push nil auxinit))
  5046.               )
  5047.               (if (and (consp item) (symbolp (car item)))
  5048.                 (if (null (cdr item))
  5049.                   (progn (push (car item) auxvar) (push nil auxinit))
  5050.                   (if (and (consp (cdr item)) (null (cddr item)))
  5051.                     (progn (push (car item) auxvar) (push (cadr item) auxinit))
  5052.                     (lambdalist-error item)
  5053.                 ) )
  5054.                 (lambdalist-error item)
  5055.           ) ) )
  5056.           (setq L (cdr L))
  5057.       ) )
  5058.       ; Hier gilt (atom L).
  5059.       (if L
  5060.         (catch 'c-error
  5061.           (c-error (DEUTSCH "Eine Lambdaliste, die einen Punkt enthΣlt, ist nur bei Macros erlaubt, nicht hier: ~S"
  5062.                     ENGLISH "Lambda lists with dots are only allowed in macros, not here: ~S"
  5063.                     FRANCAIS "Les listes lambdas contenant une paire pointΘe ne sont permises qu'avec des macros et non ici : ~S")
  5064.                    lambdalist
  5065.       ) ) )
  5066.     )
  5067.     (values
  5068.       (nreverse req)
  5069.       (nreverse optvar) (nreverse optinit) (nreverse optsvar)
  5070.       rest
  5071.       keyflag
  5072.       (nreverse keyword) (nreverse keyvar) (nreverse keyinit) (nreverse keysvar)
  5073.       allow-other-keys
  5074.       (nreverse auxvar) (nreverse auxinit)
  5075. ) ) )
  5076.  
  5077. (defun lambdalist-error (item)
  5078.   (catch 'c-error
  5079.     (c-error (DEUTSCH "UnzulΣssiges Lambdalistenelement: ~S"
  5080.               ENGLISH "Illegal lambda list element ~S"
  5081.               FRANCAIS "N'est pas permis dans une liste lambda : ~S")
  5082.              item
  5083. ) ) )
  5084.  
  5085. ; (inline-callable-function-lambda-p form n) bzw.
  5086. ; (inline-callable-function-p form n) stellt fest, ob form eine Form ist, die
  5087. ; eine Funktion liefert, die mit n (und evtl. mehr) Argumenten Inline
  5088. ; aufgerufen werden kann. (vorbehaltlich Syntax-Errors in der Lambdaliste)
  5089. ; form sollte bereits macroexpandiert sein.
  5090. (defun inline-callable-function-lambda-p (form n &optional (more nil))
  5091.   ; mu▀ von der Bauart (FUNCTION funname) sein
  5092.   (and (consp form) (eq (first form) 'FUNCTION)
  5093.        (consp (cdr form)) (null (cddr form))
  5094.        (let ((funname (second form)))
  5095.          ; funname mu▀ von der Bauart (LAMBDA lambdalist ...) sein
  5096.          (and (consp funname) (eq (first funname) 'LAMBDA) (consp (cdr funname))
  5097.               (let ((lambdalist (second funname)))
  5098.                 ; lambdalist mu▀ eine Liste sein, die kein &KEY enthΣlt
  5099.                 ; (Funktionen mit &KEY werden nicht INLINE-expandiert, weil die
  5100.                 ; Zuordnung von den Argumenten zu den Variablen nur dynamisch,
  5101.                 ; mit GETF, m÷glich ist, und das kann die in Assembler
  5102.                 ; geschriebene APPLY-Routine schneller.)
  5103.                 (and (listp lambdalist)
  5104.                      (not (position '&KEY lambdalist))
  5105.                      (not (position '&ALLOW-OTHER-KEYS lambdalist))
  5106.                      (let ((&opt-pos (position '&OPTIONAL lambdalist))
  5107.                            (&rest-pos (position '&REST lambdalist))
  5108.                            (&aux-pos (or (position '&AUX lambdalist)
  5109.                                          (length lambdalist)
  5110.                           ))         )
  5111.                        (if &rest-pos
  5112.                          ; &rest angegeben
  5113.                          (or more (>= n (or &opt-pos &rest-pos)))
  5114.                          ; &rest nicht angegeben
  5115.                          (if more
  5116.                            (<= n (if &opt-pos (- &aux-pos 1) &aux-pos))
  5117.                            (if &opt-pos
  5118.                              (<= &opt-pos n (- &aux-pos 1))
  5119.                              (= n &aux-pos)
  5120.                      ) ) ) )
  5121.               ) )
  5122.        ) )
  5123. ) )
  5124. (defun inline-callable-function-p (form n)
  5125.   (or (inline-callable-function-lambda-p form n)
  5126.       (and (consp form) (eq (first form) 'FUNCTION)
  5127.            (consp (cdr form)) (null (cddr form))
  5128.            (let ((fun (second form)))
  5129.              ; fun mu▀ ein Funktionsname mit Inline-Definition sein,
  5130.              ; dann wird (FUNCALL form ...) spΣter zu (fun ...)
  5131.              ; umgewandelt und inline compiliert werden.
  5132.              ; Siehe c-FUNCALL, c-FUNCTION-CALL, c-GLOBAL-FUNCTION-CALL.
  5133.              (and (function-name-p fun)
  5134.                   (null (fenv-search fun))
  5135.                   (not (and (symbolp fun) (or (special-form-p fun) (macro-function fun))))
  5136.                   (not (declared-notinline fun))
  5137.                   (or #| ;; Lohnt sich wohl nicht
  5138.                       (and (equal fun (fnode-name *func*))
  5139.                            (member `(SYS::IN-DEFUN ,fun) *denv* :test #'equal)
  5140.                            (multiple-value-bind (req opt rest-flag key-flag keylist allow-flag)
  5141.                                (fdescr-signature (cons *func* nil))
  5142.                              (declare (ignore keylist allow-flag))
  5143.                              (and (<= req n) (or rest-flag (<= n (+ req opt))) (not key-flag))
  5144.                       )    )
  5145.                       |#
  5146.                       (let ((inline-lambdabody
  5147.                               (or (and *compiling-from-file*
  5148.                                        (cdr (assoc fun *inline-definitions* :test #'equal))
  5149.                                   )
  5150.                                   (get (get-funname-symbol fun) 'sys::inline-expansion)
  5151.                            )) )
  5152.                         (and #| inline-lambdabody |#
  5153.                              (consp inline-lambdabody)
  5154.                              (inline-callable-function-lambda-p `(FUNCTION (LAMBDA ,@inline-lambdabody)) n)
  5155.                        ) )
  5156. ) )   )    ) )    )
  5157.  
  5158.  
  5159. ;; Special-deklarierte Symbole:
  5160.  
  5161. (defvar *specials*) ; Liste aller zuletzt special deklarierten Symbole
  5162. (defvar *ignores*) ; Liste aller zuletzt ignore deklarierten Symbole
  5163. (defvar *ignorables*) ; Liste aller zuletzt ignorable deklarierten Symbole
  5164.  
  5165. ; pusht alle Symbole von specials als Variablen auf *venv* :
  5166. (defun push-specials ()
  5167.   (apply #'push-*venv* (mapcar #'make-special-var *specials*))
  5168. )
  5169.  
  5170. ; ▄berprⁿft eine Variable, ob sie zu Recht ignore-deklariert ist oder nicht...
  5171. (defun ignore-check (var)
  5172.   (let ((sym (var-name var)))
  5173.     (if (member sym *ignores* :test #'eq)
  5174.       ; var ignore-deklariert
  5175.       (if (var-specialp var)
  5176.         (c-warn (DEUTSCH "Binden der Variablen ~S kann trotz IGNORE-Deklaration~%Seiteneffekte haben, weil sie SPECIAL deklariert ist."
  5177.                  ENGLISH "Binding variable ~S can cause side effects despite of IGNORE declaration~%since it is declared SPECIAL."
  5178.                  FRANCAIS "Lier la variable ~S peut avoir des effets de bord malgrΘ la dΘclaration IGNORE~%car elle a ΘtΘ dΘclarΘe SPECIAL.")
  5179.                 sym
  5180.         )
  5181.         (if (var-usedp var)
  5182.           (c-warn (DEUTSCH "Variable ~S wird trotz IGNORE-Deklaration benutzt."
  5183.                    ENGLISH "variable ~S is used despite of IGNORE declaration."
  5184.                    FRANCAIS "La variable ~S est utilisΘe malgrΘ la dΘclaration IGNORE.")
  5185.                   sym
  5186.       ) ) )
  5187.       ; var nicht ignore-deklariert
  5188.       (unless (member sym *ignorables* :test #'eq)
  5189.         ; var auch nicht ignorable-deklariert
  5190.         (unless (or (var-specialp var) (var-usedp var))
  5191.           ; var lexikalisch und unbenutzt
  5192.           (unless (null (symbol-package sym)) ; sym ein (gensym) ?
  5193.             ; (Symbole ohne Home-Package kommen nicht vom Benutzer, die Warnung
  5194.             ; wⁿrde nur verwirren).
  5195.             (c-warn (DEUTSCH "Variable ~S wird nicht benutzt.~%Schreibfehler oder fehlende IGNORE-Deklaration?"
  5196.                      ENGLISH "variable ~S is not used.~%Misspelled or missing IGNORE declaration?"
  5197.                      FRANCAIS "La variable ~S n'est pas utilisΘe.~%Mauvaise orthographe ou dΘclaration IGNORE manquante?")
  5198.                     sym
  5199. ) ) ) ) ) ) )
  5200.  
  5201. ; liefert den Code, der zum neuen Aufbau einer Closure und ihrer Unterbringung
  5202. ; im Stack n÷tig ist:
  5203. ; Dieser Code erweitert das von (cdr venvc) beschriebene Venv um closurevars,
  5204. ; (cdr stackz) ist der aktuelle Stackzustand.
  5205. ; Nach Aufbau der Closure sind venvc bzw. stackz die aktuellen ZustΣnde.
  5206. (defun c-MAKE-CLOSURE (closurevars venvc stackz)
  5207.   (if closurevars
  5208.     `((VENV ,(cdr venvc) ,(cdr stackz))
  5209.       (MAKE-VECTOR1&PUSH ,(length closurevars))
  5210.      )
  5211.     '()
  5212. ) )
  5213.  
  5214. ;; Es gibt zwei Arten von Variablen-Bindungs-Vorgehensweisen:
  5215. ; 1. fixed-var: die Variable hat eine Position im Stack, darf nicht wegoptimiert
  5216. ;               werden. Ist die Variable dann doch in der Closure, so mu▀ ihr
  5217. ;               Wert dorthin ⁿbertragen werden; ist die Variable dynamisch, so
  5218. ;               mu▀ ein Bindungsframe aufgemacht werden.
  5219. ;               Auftreten: MULTIPLE-VALUE-BIND, Lambda-Ausdruck (required,
  5220. ;               optional, rest, keyword - Parameter)
  5221. ; 2. movable-var: die Variable darf wegoptimiert werden, falls sie konstant ist
  5222. ;                 (sie entweder dynamisch und konstant ist oder lexikalisch
  5223. ;                  und an eine Konstante gebunden und nie geSETQed wird). Hier
  5224. ;                 spielt also der Init-Wert eine Rolle.
  5225. ;                 Auftreten: LET, LET*, Lambda-Ausdruck (optional-svar,
  5226. ;                 keyword-svar, aux-Variablen)
  5227.  
  5228. ;; 1. fixed-var
  5229.  
  5230. ; Bindung einer fixed-var:
  5231. ; symbol --> Variable
  5232. ; LΣ▀t *stackz* unverΣndert.
  5233. (defun bind-fixed-var-1 (symbol)
  5234.   (if (or (constantp symbol)
  5235.           (proclaimed-special-p symbol)
  5236.           (member symbol *specials* :test #'eq)
  5237.       )
  5238.     ; mu▀ symbol dynamisch binden:
  5239.     (progn
  5240.       (when (c-constantp symbol)
  5241.         (catch 'c-error
  5242.           (c-error (DEUTSCH "Konstante ~S kann nicht gebunden werden."
  5243.                     ENGLISH "Constant ~S cannot be bound."
  5244.                     FRANCAIS "La constante ~S ne peut pas Ωtre liΘe.")
  5245.                    symbol
  5246.       ) ) )
  5247.       (make-special-var symbol)
  5248.     )
  5249.     ; mu▀ symbol lexikalisch binden:
  5250.     (make-var :name symbol :specialp nil :constantp nil
  5251.               :usedp nil :really-usedp nil :closurep nil
  5252.               :stackz *stackz* :venvc *venvc*
  5253.     )
  5254. ) )
  5255.  
  5256. ; registriert in *stackz*, da▀ eine fixed-var gebunden wird
  5257. (defun bind-fixed-var-2 (var)
  5258.   (when (and (var-specialp var) (not (var-constantp var)))
  5259.     (push '(BIND 1) *stackz*)
  5260. ) )
  5261.  
  5262. ; liefert den Code, der die Variable var an den Inhalt von stackdummyvar
  5263. ; bindet. stackz ist der Stackzustand vor dem Binden dieser Variablen.
  5264. (defun c-bind-fixed-var (var stackdummyvar stackz)
  5265.   (if (var-specialp var)
  5266.     (if (var-constantp var)
  5267.       '() ; Konstante kann nicht gebunden werden
  5268.       `((GET ,stackdummyvar ,*venvc* ,stackz)
  5269.         (BIND ,(new-const (var-name var)))
  5270.        )
  5271.     )
  5272.     ; var lexikalisch, nach Definition nicht konstant
  5273.     (if (var-closurep var)
  5274.       `((GET ,stackdummyvar ,*venvc* ,stackz)
  5275.         (SET ,var ,*venvc* ,stackz)
  5276.        )
  5277.       '() ; var und stackdummyvar identisch
  5278. ) ) )
  5279.  
  5280. ; Kreiert je eine Stackvariable und eine Fixed-Variable zu jedem Symbol aus der
  5281. ; Variablenliste symbols und liefert beide Listen als Werte.
  5282. (defun process-fixed-var-list (symbols &optional optimflags)
  5283.   (do ((symbolsr symbols (cdr symbolsr))
  5284.        (optimflagsr optimflags (cdr optimflagsr))
  5285.        (varlist nil) ; Liste der Variablen
  5286.        (stackvarlist nil)) ; Liste der Stackvariablen (teils Dummys)
  5287.       ((null symbolsr) (values (nreverse varlist) (nreverse stackvarlist)))
  5288.     (push 1 *stackz*)
  5289.     ; (mit constantp=nil und really-usedp=t, um eine Wegoptimierung zu vermeiden)
  5290.     (push (make-var :name (gensym) :specialp nil :constantp nil
  5291.                     :usedp nil :really-usedp (null (car optimflagsr))
  5292.                     :closurep nil :stackz *stackz* :venvc *venvc*
  5293.           )
  5294.           stackvarlist
  5295.     )
  5296.     (push (bind-fixed-var-1 (car symbolsr)) varlist)
  5297. ) )
  5298.  
  5299. ; Eliminiert alle Zuweisungen auf eine unbenutzte Variable.
  5300. (defun unmodify-unused-var (var)
  5301.   (dolist (modified (var-modified-list var))
  5302.     (if (cddr modified)
  5303.       ; Wert der Zuweisung wird gebraucht
  5304.       (let ((set-anode (second modified))) ; Anode der Zuweisung selbst
  5305.         (setf (anode-code set-anode) '((VALUES1))) ; Zuweisung entfernen
  5306.       )
  5307.       ; Wert der Zuweisung wird nicht gebraucht
  5308.       (progn
  5309.         (let ((value-anode (first modified))) ; Anode fⁿr zugewiesenen Wert
  5310.           (when (null (cdr (anode-seclass value-anode)))
  5311.             (setf (anode-code value-anode) '()) ; evtl. Wert-Form entfernen
  5312.         ) )
  5313.         (let ((set-anode (second modified))) ; Anode der Zuweisung selbst
  5314.           (setf (anode-code set-anode) '()) ; Zuweisung entfernen
  5315. ) ) ) ) )
  5316.  
  5317. ; ▄berprⁿft und optimiert die Variablen
  5318. ; und liefert die Liste der Closure-Variablen (in der richtigen Reihenfolge).
  5319. (defun checking-fixed-var-list (varlist &optional optimflaglist)
  5320.   (let ((closurevarlist '()))
  5321.     (dolist (var varlist (nreverse closurevarlist))
  5322.       ; 1. Schritt: eventuelle Warnungen ausgeben
  5323.       (ignore-check var)
  5324.       ; 2. Schritt: Variablen-Ort (Stack oder Closure) endgⁿltig bestimmen,
  5325.       ; evtl. optimieren
  5326.       (unless (var-specialp var)
  5327.         ; nur lexikalische Variablen k÷nnen in der Closure liegen,
  5328.         ; nur bei lexikalischen Variablen kann optimiert werden
  5329.         (if (not (var-really-usedp var))
  5330.           ; Variable lexikalisch und unbenutzt
  5331.           (progn ; Variable eliminieren
  5332.             (setf (var-closurep var) nil)
  5333.             (when (car optimflaglist) ; optimierbare fixed-var?
  5334.               (setf (first (var-stackz var)) 0) ; aus dem Stack entfernen
  5335.               (setf (car optimflaglist) 'GONE) ; als gestrichen vermerken
  5336.             )
  5337.             (unmodify-unused-var var) ; Zuweisungen auf var eliminieren
  5338.           )
  5339.           (when (var-closurep var)
  5340.             ; Variable mu▀ in der Closure liegen
  5341.             (push var closurevarlist)
  5342.       ) ) )
  5343.       (setq optimflaglist (cdr optimflaglist))
  5344. ) ) )
  5345.  
  5346. ;; 2. movable-var
  5347.  
  5348. ; Beim Binden einer Variablen var an einen Anode anode:
  5349. ; Wird eine lexikalische Variable an den Wert an einer lexikalischen Variablen
  5350. ; gebunden? Wenn ja, an welche Variable?
  5351. (defun bound-to-var-p (var anode)
  5352.   (if (var-specialp var)
  5353.     nil
  5354.     ; var lexikalisch
  5355.     (loop
  5356.       (unless (eql (length (anode-code anode)) 1) (return nil))
  5357.       (setq anode (first (anode-code anode)))
  5358.       (unless (anode-p anode)
  5359.         (if (and (consp anode) (eq (first anode) 'GET))
  5360.           ; Code zum Anode besteht genau aus ((GET outervar ...)).
  5361.           (return (second anode))
  5362.           (return nil)
  5363.     ) ) )
  5364. ) )
  5365.  
  5366. ; Bindung einer movable-var:
  5367. ; symbol form-anode --> Variable
  5368. ; erweitert *stackz* um genau einen Eintrag
  5369. (defun bind-movable-var (symbol form-anode)
  5370.   (if (or (constantp symbol)
  5371.           (proclaimed-special-p symbol)
  5372.           (member symbol *specials* :test #'eq)
  5373.       )
  5374.     ; mu▀ symbol dynamisch binden:
  5375.     (progn
  5376.       (if (c-constantp symbol)
  5377.         (progn
  5378.           (catch 'c-error
  5379.             (c-error (DEUTSCH "Konstante ~S kann nicht gebunden werden."
  5380.                       ENGLISH "Constant ~S cannot be bound."
  5381.                       FRANCAIS "La constante ~S ne peut pas Ωtre liΘe.")
  5382.                      symbol
  5383.           ) )
  5384.           (push 0 *stackz*)
  5385.         )
  5386.         (push '(BIND 1) *stackz*)
  5387.       )
  5388.       (make-special-var symbol)
  5389.     )
  5390.     ; mu▀ symbol lexikalisch binden:
  5391.     (let ((var
  5392.             (progn
  5393.               (push 1 *stackz*) ; vorlΣufig: 1 Platz auf dem Stack
  5394.               (make-var :name symbol :specialp nil
  5395.                 :constantp (anode-constantp form-anode) ; wird bei Zuweisungen auf NIL gesetzt
  5396.                 :constant (if (anode-constantp form-anode) (anode-constant form-anode))
  5397.                 :usedp nil :really-usedp nil :closurep nil ; wird evtl. auf T gesetzt
  5398.                 :stackz *stackz* :venvc *venvc*
  5399.          )) ) )
  5400.       (let ((outervar (bound-to-var-p var form-anode)))
  5401.         (when outervar ; Wird var an eine Variable outervar gebunden, so
  5402.                        ; darf spΣter evtl. jede Referenz zu var in eine
  5403.                        ; Referenz zu outervar umgewandelt werden.
  5404.           (push (list var form-anode) (var-replaceable-list outervar))
  5405.       ) )
  5406.       var
  5407. ) ) )
  5408.  
  5409. ; liefert den Code, der die Variable var an A0 bindet:
  5410. (defun c-bind-movable-var (var)
  5411.   (if (var-specialp var)
  5412.     (if (var-constantp var)
  5413.       '() ; dynamische Konstanten k÷nnen nicht gebunden werden
  5414.       `((BIND ,(new-const (var-name var))))
  5415.     )
  5416.     (if (var-closurep var)
  5417.       ; Closure-Variable schreiben:
  5418.       ; (var-stackz var) = (0 . ...) ist der aktuelle Stackzustand.
  5419.       `((SET ,var ,*venvc* ,(var-stackz var)))
  5420.       ; lexikalische Variable: wurde eventuell aus dem Stack eliminiert
  5421.       (if (zerop (first (var-stackz var)))
  5422.         '()
  5423.         `((PUSH)) ; im Stack: in die nΣchstuntere Stacklocation schreiben
  5424. ) ) ) )
  5425.  
  5426. ; liefert den Code, der die Variable var an das Ergebnis des ANODEs anode bindet
  5427. (defun c-bind-movable-var-anode (var anode)
  5428.   (let ((binding-anode
  5429.           (make-anode :type 'BIND-MOVABLE
  5430.                       :sub-anodes '()
  5431.                       :seclass '(NIL . NIL)
  5432.                       :code (c-bind-movable-var var)
  5433.        )) )
  5434.     (let ((outervar (bound-to-var-p var anode)))
  5435.       (when outervar ; Wird var an eine Variable outervar gebunden, so
  5436.                      ; darf spΣter evtl. jede Referenz zu var in eine
  5437.                      ; Referenz zu outervar umgewandelt werden.
  5438.         (dolist (innervar-info (var-replaceable-list outervar))
  5439.           (when (eq (first innervar-info) var)
  5440.             (setf (cddr innervar-info) binding-anode) ; binding-anode nachtragen
  5441.     ) ) ) )
  5442.     (list anode binding-anode)
  5443. ) )
  5444.  
  5445. ; (process-movable-var-list symbols initforms *-flag) compiliert die initforms
  5446. ; (wie bei LET/LET*) und assoziiert sie mit den Variablen zu symbols.
  5447. ; VerΣndert *venv* (bei *-flag : incrementell, sonst auf einmal).
  5448. ; Liefert drei Werte:
  5449. ; 1. Liste der Variablen,
  5450. ; 2. Liste der ANODEs zu den initforms,
  5451. ; 3. Liste der StackzustΣnde nach dem Binden der Variablen.
  5452. (defun process-movable-var-list (symbols initforms *-flag)
  5453.   (do ((symbolsr symbols (cdr symbolsr))
  5454.        (initformsr initforms (cdr initformsr))
  5455.        (varlist '())
  5456.        (anodelist '())
  5457.        (stackzlist '()))
  5458.       ((null symbolsr)
  5459.        (unless *-flag (apply #'push-*venv* varlist)) ; Binden bei LET
  5460.        (values (nreverse varlist) (nreverse anodelist) (nreverse stackzlist))
  5461.       )
  5462.     (let* ((initform (car initformsr))
  5463.            (anode (c-form initform 'ONE)) ; initform compilieren
  5464.            (var (bind-movable-var (car symbolsr) anode)))
  5465.       (push anode anodelist)
  5466.       (push var varlist)
  5467.       (push *stackz* stackzlist)
  5468.       (when *-flag (push-*venv* var)) ; Binden bei LET*
  5469. ) ) )
  5470.  
  5471. ; ▄berprⁿft und optimiert die Variablen (wie bei LET/LET*)
  5472. ; und liefert die Liste der Closure-Variablen (in der richtigen Reihenfolge).
  5473. (defun checking-movable-var-list (varlist anodelist)
  5474.   (do ((varlistr varlist (cdr varlistr))
  5475.        (anodelistr anodelist (cdr anodelistr))
  5476.        (closurevarlist '()))
  5477.       ((null varlistr) (nreverse closurevarlist))
  5478.     (let ((var (car varlistr)))
  5479.       (when var
  5480.         ; 1. Schritt: eventuelle Warnungen ausgeben
  5481.         (ignore-check var)
  5482.         ; 2. Schritt: Variablen-Ort (Stack oder Closure oder eliminiert)
  5483.         ; endgⁿltig bestimmen
  5484.         (unless (var-specialp var)
  5485.           ; nur bei lexikalischen Variablen kann optimiert werden
  5486.           (if (var-constantp var)
  5487.             ; Variable lexikalisch und konstant
  5488.             (progn ; Variable eliminieren
  5489.               (setf (var-closurep var) nil)
  5490.               (setf (first (var-stackz var)) 0) ; aus dem Stack entfernen
  5491.               (when (null (cdr (anode-seclass (car anodelistr))))
  5492.                 (setf (anode-code (car anodelistr)) '()) ; evtl. initform entfernen
  5493.             ) )
  5494.             (if (not (var-really-usedp var))
  5495.               ; Variable lexikalisch und unbenutzt
  5496.               (progn ; Variable eliminieren
  5497.                 (setf (var-closurep var) nil)
  5498.                 (setf (first (var-stackz var)) 0) ; aus dem Stack entfernen
  5499.                 (when (null (cdr (anode-seclass (car anodelistr))))
  5500.                   (setf (anode-code (car anodelistr)) '()) ; evtl. initform entfernen
  5501.                 )
  5502.                 (unmodify-unused-var var) ; Zuweisungen auf var eliminieren
  5503.               )
  5504.               (when (var-closurep var)
  5505.                 ; Variable mu▀ in der Closure liegen
  5506.                 (setf (first (var-stackz var)) 0) ; belegt 0 Stack-EintrΣge
  5507.                 (push var closurevarlist)
  5508.         ) ) ) )
  5509. ) ) ) )
  5510.  
  5511. ; Optimiert eine Liste von Variablen.
  5512. ; (In der Liste mⁿssen die lexikalisch inneren Variablen zuletzt kommen.)
  5513. (defun optimize-var-list (vars)
  5514.   (unless *no-code*
  5515.     (dolist (var (reverse vars))
  5516.       (when var
  5517.         ; Optimierung (innere Variablen zuerst):
  5518.         ; Wird eine Variable innervar an den Wert von var gebunden, wird
  5519.         ; wΣhrend der Lebensdauer von innervar weder innervar noch var verΣndert
  5520.         ; (um dies sicherstellen zu k÷nnen, mⁿssen beide lexikalisch und im Stack
  5521.         ; sein), so kann innervar durch var ersetzt werden.
  5522.         (unless (or (var-specialp var) (var-closurep var))
  5523.           ; var ist lexikalisch und im Stack
  5524.           (dolist (innervar-info (var-replaceable-list var))
  5525.             (let ((innervar (first innervar-info)))
  5526.               ; innervar ist eine movable-var, die mit var initialisiert wird.
  5527.               ; WΣhrend der Lebensdauer von innervar wird var nichts zugewiesen.
  5528.               (unless (or (var-specialp innervar) (var-closurep innervar))
  5529.                 ; innervar ist lexikalisch und im Stack
  5530.                 (when (null (var-modified-list innervar))
  5531.                   ; WΣhrend der Lebensdauer von innervar wird auch innervar
  5532.                   ; nichts zugewiesen.
  5533.                   (unless (eql (first (var-stackz innervar)) 0) ; innervar noch nicht wegoptimiert?
  5534.                     (when (cddr innervar-info) ; und innervar-info korrekt dreigliedrig?
  5535.                       ; Variable innervar eliminieren:
  5536.                       (setf (first (var-stackz innervar)) 0) ; aus dem Stack entfernen
  5537.                       ; Initialisierung und Binden von innervar eliminieren:
  5538.                       (setf (anode-code (second innervar-info)) '())
  5539.                       (setf (anode-code (cddr innervar-info)) '())
  5540.                       ; Die Referenzen auf die Variable innervar werden
  5541.                       ; in Referenzen auf die Variable var umgewandelt:
  5542.                       (let ((using-var (var-usedp var)))
  5543.                         (do ((using-innervar (var-usedp innervar) (cdr using-innervar)))
  5544.                             ((atom using-innervar))
  5545.                           (let* ((anode (car using-innervar)) ; ein Anode vom Typ VAR
  5546.                                  (code (anode-code anode))) ; sein Code, () oder ((GET ...))
  5547.                             (unless (null code)
  5548.                               ; (anode-code anode) ist von der Gestalt ((GET innervar ...))
  5549.                               (setf (second (car code)) var)
  5550.                               (push anode using-var)
  5551.                         ) ) )
  5552.                         (setf (var-usedp var) using-var)
  5553.                       )
  5554.         ) ) ) ) ) ) )
  5555. ) ) ) )
  5556.  
  5557. ; Bildet den Code, der eine Liste von Variablen, zusammen mit ihren svars,
  5558. ; bindet (wie bei Lambdabody- Optional/Key - Variablen).
  5559. (defun c-bind-with-svars (-vars -dummys s-vars -anodes s-anodes -stackzs)
  5560.   (do ((-varsr -vars (cdr -varsr)) ; fixed-vars
  5561.        (-dummysr -dummys (cdr -dummysr))
  5562.        (s-varsr s-vars (cdr s-varsr)) ; movable-vars
  5563.        (-anodesr -anodes (cdr -anodesr))
  5564.        (s-anodesr s-anodes (cdr s-anodesr))
  5565.        (-stackzsr -stackzs (cdr -stackzsr))
  5566.        (L '()))
  5567.       ((null -varsr) (nreverse L))
  5568.     (when (car s-varsr)
  5569.       (setq L
  5570.         (revappend
  5571.           (c-bind-movable-var-anode (car s-varsr) (car s-anodesr))
  5572.           L
  5573.     ) ) )
  5574.     (setq L
  5575.       (revappend
  5576.         (let* ((var (car -varsr))
  5577.                (stackdummyvar (car -dummysr))
  5578.                (anode (car -anodesr))
  5579.                (stackz (car -stackzsr))
  5580.                (label (make-label 'ONE)))
  5581.           (if (var-specialp var)
  5582.             `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5583.               ,anode
  5584.               ,label
  5585.               ,@(if (var-constantp var)
  5586.                   '() ; Konstante kann nicht gebunden werden
  5587.                   `((BIND ,(new-const (var-name var))))
  5588.                 )
  5589.              )
  5590.             ; var lexikalisch, nach Definition nicht konstant
  5591.             (if (var-closurep var)
  5592.               `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5593.                 ,anode
  5594.                 ,label
  5595.                 (SET ,var ,*venvc* ,stackz)
  5596.                )
  5597.               (if (not (var-really-usedp var))
  5598.                 ; Variable wurde in checking-fixed-var-list wegoptimiert
  5599.                 (if (cdr (anode-seclass anode))
  5600.                   `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5601.                     ,anode
  5602.                     ,label
  5603.                    )
  5604.                   '()
  5605.                 )
  5606.                 ; im Stack vorhandene Variable
  5607.                 `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5608.                   ,anode
  5609.                   (SET ,var ,*venvc* ,stackz)
  5610.                   ,label
  5611.                  )
  5612.         ) ) ) )
  5613.         L
  5614.     ) )
  5615. ) )
  5616.  
  5617. ; compiliere (name lambdalist {declaration|docstring}* {form}*), liefere FNODE
  5618. (defun c-LAMBDABODY (name lambdabody &optional fenv-cons gf-p reqoptimflags)
  5619.   (test-list lambdabody 1)
  5620.   (let* ((*func* (make-fnode :name name :enclosing *func* :venvc *venvc*))
  5621.          (*stackz* *func*) ; leerer Stack
  5622.          (*venvc* (cons *func* *venvc*))
  5623.          (*func-start-label* (make-label 'NIL))
  5624.          (*anonymous-count* 0)
  5625.          (anode (catch 'c-error
  5626.     ; ab hier wird's kompliziert
  5627.     (multiple-value-bind (reqvar  optvar optinit optsvar  restvar
  5628.                           keyflag keyword keyvar keyinit keysvar allow-other-keys
  5629.                           auxvar auxinit)
  5630.         (if fenv-cons
  5631.           (values-list (cddar fenv-cons)) ; Bei c-LABELS wurde analyze-lambdalist schon aufgerufen
  5632.           (analyze-lambdalist (car lambdabody))
  5633.         )
  5634.       (setf (fnode-req-anz *func*) (length reqvar)
  5635.             (fnode-opt-anz *func*) (length optvar)
  5636.             (fnode-rest-flag *func*) (not (eql restvar 0))
  5637.             (fnode-keyword-flag *func*) keyflag
  5638.             (fnode-keywords *func*) keyword
  5639.             (fnode-allow-other-keys-flag *func*) allow-other-keys
  5640.       )
  5641.       (when fenv-cons (setf (caar fenv-cons) *func*)) ; Fixup fⁿr c-LABELS
  5642.       (multiple-value-bind (body-rest declarations)
  5643.           (parse-body (cdr lambdabody) t (vector *venv* *fenv*))
  5644.         (let ((oldstackz *stackz*)
  5645.               (*stackz* *stackz*)
  5646.               (*denv* *denv*)
  5647.               (*venv* *venv*)
  5648.               (*venvc* *venvc*)
  5649.               *specials* *ignores* *ignorables*
  5650.               req-vars req-dummys req-stackzs
  5651.               opt-vars opt-dummys opt-anodes opts-vars opts-anodes opt-stackzs
  5652.               rest-vars rest-dummys rest-stackzs
  5653.               key-vars key-dummys key-anodes keys-vars keys-anodes key-stackzs
  5654.               aux-vars aux-anodes
  5655.               closuredummy-stackz closuredummy-venvc
  5656.              )
  5657.           (multiple-value-setq (*specials* *ignores* *ignorables*)
  5658.             (process-declarations declarations)
  5659.           )
  5660.           ; Special-Variable auf *venv* pushen:
  5661.           (push-specials)
  5662.           ; Sichtbarkeit von Closure-Dummyvar:
  5663.           (push nil *venvc*)
  5664.           (setq closuredummy-venvc *venvc*)
  5665.           ; Stack-Dummy-Variable fⁿr die reqvar,optvar,restvar,keyvar bilden:
  5666.           (multiple-value-setq (req-vars req-dummys)
  5667.             (process-fixed-var-list reqvar reqoptimflags)
  5668.           )
  5669.           (multiple-value-setq (opt-vars opt-dummys)
  5670.             (process-fixed-var-list optvar)
  5671.           )
  5672.           (multiple-value-setq (rest-vars rest-dummys)
  5673.             (if (eql restvar 0)
  5674.               (values '() '())
  5675.               (process-fixed-var-list (list restvar))
  5676.           ) )
  5677.           (multiple-value-setq (key-vars key-dummys)
  5678.             (process-fixed-var-list keyvar)
  5679.           )
  5680.           ; Platz fⁿr die Funktion selbst (unter den Argumenten):
  5681.           (push 1 *stackz*)
  5682.           ; Platz fⁿr Closure-Dummyvar:
  5683.           (push 0 *stackz*)
  5684.           (setq closuredummy-stackz *stackz*)
  5685.           ; Bindungen der required-Parameter aktivieren:
  5686.           (setq req-stackzs (bind-req-vars req-vars))
  5687.           ; Bindungen der optional-Parameter/svar aktivieren:
  5688.           (multiple-value-setq (opt-anodes opt-stackzs opts-vars opts-anodes)
  5689.             (bind-opt-vars opt-vars opt-dummys optinit optsvar)
  5690.           )
  5691.           ; Bindung des rest-Parameters aktivieren:
  5692.           (unless (eql restvar 0)
  5693.             (setq rest-stackzs (bind-rest-vars rest-vars))
  5694.           )
  5695.           ; Bindungen der keyword-Parameter/svar aktivieren:
  5696.           (multiple-value-setq (key-anodes key-stackzs keys-vars keys-anodes)
  5697.             (bind-opt-vars key-vars key-dummys keyinit keysvar)
  5698.           )
  5699.           ; Bindungen der Aux-Variablen aktivieren:
  5700.           (multiple-value-setq (aux-vars aux-anodes)
  5701.             (bind-aux-vars auxvar auxinit)
  5702.           )
  5703.           (let* ((body-anode (c-form `(PROGN ,@body-rest) 'ALL))
  5704.                  ; ▄berprⁿfen der Variablen:
  5705.                  (closurevars
  5706.                    (append
  5707.                      (checking-fixed-var-list req-vars reqoptimflags)
  5708.                      (checking-fixed-var-list opt-vars)
  5709.                      (checking-movable-var-list opts-vars opts-anodes)
  5710.                      (checking-fixed-var-list rest-vars)
  5711.                      (checking-fixed-var-list key-vars)
  5712.                      (checking-movable-var-list keys-vars keys-anodes)
  5713.                      (checking-movable-var-list aux-vars aux-anodes)
  5714.                  ) )
  5715.                  (codelist
  5716.                    `(,*func-start-label*
  5717.                      ,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  5718.                      ,@(mapcap #'c-bind-fixed-var req-vars req-dummys req-stackzs)
  5719.                      ,@(c-bind-with-svars opt-vars opt-dummys opts-vars opt-anodes opts-anodes opt-stackzs)
  5720.                      ,@(mapcap #'c-bind-fixed-var rest-vars rest-dummys rest-stackzs)
  5721.                      ,@(c-bind-with-svars key-vars key-dummys keys-vars key-anodes keys-anodes key-stackzs)
  5722.                      ,@(mapcap #'c-bind-movable-var-anode aux-vars aux-anodes)
  5723.                      ,body-anode
  5724.                      (UNWIND ,*stackz* ,oldstackz t)
  5725.                      (RET)
  5726.                  )  )
  5727.                  (anode
  5728.                    (make-anode
  5729.                      :type 'LAMBDABODY
  5730.                      :source lambdabody
  5731.                      :sub-anodes `(,@opt-anodes ,@(remove nil opts-anodes)
  5732.                                    ,@key-anodes ,@(remove nil keys-anodes)
  5733.                                    ,@aux-anodes ,body-anode
  5734.                                   )
  5735.                      :seclass '(T . T) ; die Seiteneffektklasse dieses Anode ist irrelevant
  5736.                      :stackz oldstackz
  5737.                      :code codelist
  5738.                 )) )
  5739.             (when closurevars
  5740.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  5741.               (setf (first closuredummy-venvc)
  5742.                 (cons closurevars closuredummy-stackz)
  5743.             ) )
  5744.             (optimize-var-list (append req-vars opt-vars opts-vars rest-vars key-vars keys-vars aux-vars))
  5745.             anode
  5746.     ) ) ) )
  5747.     ; das war die Produktion des Anode
  5748.         ))      )
  5749.     (setf (fnode-code *func*) anode)
  5750.     (when reqoptimflags (decf (fnode-req-anz *func*) (count 'GONE reqoptimflags)))
  5751.     (when (eq (anode-type anode) 'ERROR)
  5752.       ; korrekte, aber nichtstuende Funktion daraus machen
  5753.       (setf (fnode-req-anz *func*) 0
  5754.             (fnode-opt-anz *func*) 0
  5755.             (fnode-rest-flag *func*) t
  5756.             (fnode-keyword-flag *func*) nil
  5757.             (fnode-keywords *func*) '()
  5758.             (fnode-allow-other-keys-flag *func*) nil
  5759.             (anode-code (fnode-code *func*)) `((NIL) (SKIP 2) (RET))
  5760.     ) )
  5761.     (setf (fnode-gf-p *func*) gf-p)
  5762.     (setf (fnode-Consts-Offset *func*)
  5763.       (+ (setf (fnode-Keyword-Offset *func*)
  5764.            (+ (setf (fnode-Tagbodys-Offset *func*)
  5765.                 (+ (setf (fnode-Blocks-Offset *func*)
  5766.                      (if (fnode-venvconst *func*) 1 0)
  5767.                    )
  5768.                    (length (fnode-Blocks *func*))
  5769.               ) )
  5770.               (length (fnode-Tagbodys *func*))
  5771.          ) )
  5772.          (length (fnode-Keywords *func*))
  5773.     ) )
  5774.     (when gf-p
  5775.       ; Der Dispatch generischer Funktionen kann nicht auf externe Blocks und
  5776.       ; Tagbodys verweisen. Die Keywords allerdings werden notgedrungen verlagert.
  5777.       (when (or (fnode-Blocks *func*) (fnode-Tagbodys *func*))
  5778.         (compiler-error 'c-LAMBDABODY "GF")
  5779.       )
  5780.       ; Nun ist (fnode-Keyword-Offset *func*) = (fnode-Tagbodys-Offset *func*) =
  5781.       ;       = (fnode-Blocks-Offset *func*) = (if (fnode-venvconst *func*) 1 0)
  5782.     )
  5783.     *func*
  5784. ) )
  5785. (defun bind-req-vars (req-vars)
  5786.   (let ((req-stackzs '()))
  5787.     (dolist (var req-vars)
  5788.       (push-*venv* var)
  5789.       (push *stackz* req-stackzs)
  5790.       (bind-fixed-var-2 var)
  5791.     )
  5792.     (nreverse req-stackzs)
  5793. ) )
  5794. (defun bind-opt-vars (opt-vars opt-dummys optinit optsvar)
  5795.   (let ((opt-anodes '())
  5796.         (opt-stackzs '())
  5797.         (opts-vars '())
  5798.         (opts-anodes '()))
  5799.     (do ((opt-varsr opt-vars (cdr opt-varsr))
  5800.          (opt-dummysr opt-dummys (cdr opt-dummysr))
  5801.          (optinitr optinit (cdr optinitr))
  5802.          (optsvarr optsvar (cdr optsvarr)))
  5803.         ((null opt-varsr))
  5804.       (if (eql (car optsvarr) 0)
  5805.         (progn (push nil opts-vars) (push nil opts-anodes))
  5806.         (let* ((anode
  5807.                  (make-anode
  5808.                    :type 'OPTIONAL-SVAR
  5809.                    :sub-anodes '()
  5810.                    :seclass (cons (list (car opt-dummysr)) 'NIL)
  5811.                    :code `((BOUNDP ,(car opt-dummysr) ,*venvc* ,*stackz*))
  5812.                ) )
  5813.                (var (bind-movable-var (car optsvarr) anode))
  5814.               )
  5815.           (push anode opts-anodes)
  5816.           (push var opts-vars)
  5817.       ) )
  5818.       (push (c-form (car optinitr) 'ONE) opt-anodes)
  5819.       (push-*venv* (car opt-varsr))
  5820.       (push *stackz* opt-stackzs) (bind-fixed-var-2 (car opt-varsr))
  5821.       (unless (eql (car optsvarr) 0) (push-*venv* (car opts-vars)))
  5822.     )
  5823.     (values
  5824.       (nreverse opt-anodes) (nreverse opt-stackzs)
  5825.       (nreverse opts-vars) (nreverse opts-anodes)
  5826.     )
  5827. ) )
  5828. (defun bind-rest-vars (rest-vars)
  5829.   (let ((rest-stackzs '()))
  5830.     (push-*venv* (car rest-vars))
  5831.     (push *stackz* rest-stackzs)
  5832.     (bind-fixed-var-2 (car rest-vars))
  5833.     rest-stackzs ; (nreverse rest-stackzs) unn÷tig
  5834. ) )
  5835. (defun bind-aux-vars (auxvar auxinit)
  5836.   (let ((aux-vars '())
  5837.         (aux-anodes '()))
  5838.     (do ((auxvarr auxvar (cdr auxvarr))
  5839.          (auxinitr auxinit (cdr auxinitr)))
  5840.         ((null auxvarr))
  5841.       (let* ((initform (car auxinitr))
  5842.              (anode (c-form initform 'ONE))
  5843.              (var (bind-movable-var (car auxvarr) anode)))
  5844.         (push anode aux-anodes)
  5845.         (push var aux-vars)
  5846.         (push-*venv* var)
  5847.     ) )
  5848.     (values (nreverse aux-vars) (nreverse aux-anodes))
  5849. ) )
  5850.  
  5851. ; liefert den ANODE, der (bei gegebenem aktuellem Stackzustand)
  5852. ; die zu einem FNODE geh÷rende Funktion als Wert liefert.
  5853. (defun c-FNODE-FUNCTION (fnode &optional (*stackz* *stackz*))
  5854.   (make-anode
  5855.     :type 'FUNCTION
  5856.     :sub-anodes '()
  5857.     :seclass '(NIL . NIL)
  5858.     :code (if (zerop (fnode-keyword-offset fnode))
  5859.             `((FCONST ,fnode))
  5860.             `(,@(if (fnode-Venvconst fnode)
  5861.                   (prog1 ; beim Aufbau mitzugebendes Venv
  5862.                     `((VENV ,(fnode-venvc fnode) ,*stackz*)
  5863.                       (PUSH)
  5864.                      )
  5865.                     (setq *stackz* (cons 1 *stackz*))
  5866.                 ) )
  5867.               ,@(mapcap ; beim Aufbau mitzugebende Block-Conses
  5868.                   #'(lambda (block)
  5869.                       (prog1
  5870.                         `(,(if (member block (fnode-Blocks *func*) :test #'eq)
  5871.                              `(BCONST ,block)
  5872.                              `(GET ,(block-consvar block) ,*venvc* ,*stackz*)
  5873.                            )
  5874.                            (PUSH)
  5875.                          )
  5876.                         (setq *stackz* (cons 1 *stackz*))
  5877.                     ) )
  5878.                   (fnode-Blocks fnode)
  5879.                 )
  5880.               ,@(mapcap ; beim Aufbau mitzugebende Tagbody-Conses
  5881.                   #'(lambda (tagbody)
  5882.                       (prog1
  5883.                         `(,(if (member tagbody (fnode-Tagbodys *func*) :test #'eq)
  5884.                              `(GCONST ,tagbody)
  5885.                              `(GET ,(tagbody-consvar tagbody) ,*venvc* ,*stackz*)
  5886.                            )
  5887.                            (PUSH)
  5888.                          )
  5889.                         (setq *stackz* (cons 1 *stackz*))
  5890.                     ) )
  5891.                   (fnode-Tagbodys fnode)
  5892.                 )
  5893.               (COPY-CLOSURE ,fnode ,(fnode-keyword-offset fnode))
  5894.              )
  5895.           )
  5896. ) )
  5897.  
  5898.  
  5899. ;        ERSTER PASS :   S P E C I A L   F O R M S
  5900.  
  5901. ; compiliere (PROGN {form}*)
  5902. ; keine Formen -> NIL, genau eine Form -> diese Form,
  5903. ; mindestens zwei Formen -> alle der Reihe nach, nur bei der letzten kommt es
  5904. ; auf die Werte an.
  5905. (defun c-PROGN ()
  5906.   (test-list *form* 1)
  5907.   (let ((L (cdr *form*))) ; Liste der Formen
  5908.     (cond ((null L) (c-NIL)) ; keine Form -> NIL
  5909.           ((null (cdr L)) (c-form (car L))) ; genau eine Form
  5910.           (t (do (#+COMPILER-DEBUG (anodelist '())
  5911.                   (seclass '(NIL . NIL))
  5912.                   (codelist '())
  5913.                   (Lr L)) ; restliche Formenliste
  5914.                  ((null Lr)
  5915.                   (make-anode
  5916.                     :type 'PROGN
  5917.                     :sub-anodes (nreverse anodelist)
  5918.                     :seclass seclass
  5919.                     :code (nreverse codelist)
  5920.                  ))
  5921.                (let* ((formi (pop Lr)) ; i-te Form
  5922.                       (anodei (c-form formi (if (null Lr) *for-value* 'NIL))))
  5923.                  #+COMPILER-DEBUG (push anodei anodelist)
  5924.                  (seclass-or-f seclass anodei)
  5925.                  (push anodei codelist)
  5926. ) ) )     )  ) )
  5927.  
  5928. ; compiliere (PROG1 form1 {form}*)
  5929. ; bei *for-value* mu▀ der Wert von form1 im Stack gerettet werden
  5930. (defun c-PROG1 ()
  5931.   (test-list *form* 2)
  5932.   (if (or (null *for-value*) (and (eq *for-value* 'ONE) (null (cddr *form*))))
  5933.     (c-form `(PROGN ,@(cdr *form*)))
  5934.     (let ((anode1 (c-form (second *form*) 'ONE))
  5935.           (anode2 (let ((*stackz* (cons 1 *stackz*)))
  5936.                     (c-form `(PROGN ,@(cddr *form*)) 'NIL)
  5937.          ))       )
  5938.       (make-anode
  5939.         :type 'PROG1
  5940.         :sub-anodes (list anode1 anode2)
  5941.         :seclass (anodes-seclass-or anode1 anode2)
  5942.         :code `(,anode1 (PUSH) ,anode2 (POP))
  5943. ) ) ) )
  5944.  
  5945. ; compiliere (PROG2 form1 form2 {form}*)
  5946. (defun c-PROG2 ()
  5947.   (test-list *form* 3)
  5948.   (c-form `(PROGN ,(second *form*) (PROG1 ,(third *form*) ,@(cdddr *form*))))
  5949. )
  5950.  
  5951. ; compiliere (IF form1 form2 [form3])
  5952. ; ist form1 eine Konstante, so kann der Compiler die Fallunterscheidung treffen.
  5953. (defun c-IF ()
  5954.   (test-list *form* 3 4)
  5955.   (let ((form1 (second *form*))
  5956.         (form2 (third *form*))
  5957.         (form3 (fourth *form*))) ; = NIL, falls *form* nur 3 lang ist
  5958.     (let ((anode1 (c-form form1 'ONE)))
  5959.       (if (anode-constantp anode1)
  5960.         (if (anode-constant-value anode1)
  5961.           (prog1 (c-form form2) (let ((*no-code* t)) (c-form form3 'NIL)))
  5962.           (prog2 (let ((*no-code* t)) (c-form form2 'NIL)) (c-form form3))
  5963.         )
  5964.         (let ((anode2 (c-form form2))
  5965.               (anode3 (c-form form3))
  5966.               (label1 (make-label 'NIL))
  5967.               (label2 (make-label *for-value*)))
  5968.           (make-anode
  5969.             :type 'IF
  5970.             :sub-anodes (list anode1 anode2 anode3)
  5971.             :seclass (anodes-seclass-or anode1 anode2 anode3)
  5972.             :code
  5973.               `(,anode1
  5974.                 (JMPIFNOT ,label1)
  5975.                 ,anode2
  5976.                 (JMP ,label2)
  5977.                 ,label1
  5978.                 ,anode3
  5979.                 ,label2
  5980.                )
  5981. ) ) ) ) ) )
  5982.  
  5983. ; compiliere (WHEN form1 {form}*)
  5984. (defun c-WHEN ()
  5985.   (test-list *form* 2)
  5986.   (c-form `(IF ,(second *form*) (PROGN ,@(cddr *form*))))
  5987. )
  5988.  
  5989. ; compiliere (UNLESS form1 {form}*)
  5990. (defun c-UNLESS ()
  5991.   (test-list *form* 2)
  5992.   (c-form `(IF ,(second *form*) NIL (PROGN ,@(cddr *form*))))
  5993. )
  5994.  
  5995. ; compiliere (AND {form}*)
  5996. (defun c-AND ()
  5997.   (test-list *form* 1)
  5998.   (cond ((null (cdr *form*)) ; keine Formen
  5999.          (make-anode
  6000.            :type 'AND
  6001.            :sub-anodes '()
  6002.            :seclass '(NIL . NIL)
  6003.            :code '((T))
  6004.         ))
  6005.         ((null (cddr *form*)) (c-form (second *form*))) ; genau eine Form
  6006.         (t (do (#+COMPILER-DEBUG (anodelist '())
  6007.                 (seclass '(NIL . NIL))
  6008.                 (codelist '())
  6009.                 (Lr (cdr *form*))
  6010.                 (label (make-label *for-value*))) ; Label am Ende
  6011.                ((null Lr)
  6012.                 (push label codelist)
  6013.                 (make-anode
  6014.                   :type 'AND
  6015.                   :sub-anodes (nreverse anodelist)
  6016.                   :seclass seclass
  6017.                   :code (nreverse codelist)
  6018.                ))
  6019.              (let* ((formi (pop Lr))
  6020.                     (anodei (c-form formi (if (null Lr) *for-value* 'ONE))))
  6021.                #+COMPILER-DEBUG (push anodei anodelist)
  6022.                (seclass-or-f seclass anodei)
  6023.                (if (null Lr)
  6024.                  ; letzte Form -> direkt ⁿbernehmen
  6025.                  (push anodei codelist)
  6026.                  ; nicht letzte Form -> Test kreieren
  6027.                  (if (anode-constantp anodei)
  6028.                    ; Konstante /= NIL -> weglassen, Konstante NIL -> fertig
  6029.                    (unless (anode-constant-value anodei)
  6030.                      (if *for-value* (push '(NIL) codelist))
  6031.                      (let ((*no-code* t)) (dolist (form Lr) (c-form form 'NIL)))
  6032.                      (setq Lr nil)
  6033.                    )
  6034.                    (progn ; normaler Test
  6035.                      (push anodei codelist)
  6036.                      (push `(,(if *for-value* 'JMPIFNOT1 'JMPIFNOT) ,label)
  6037.                            codelist
  6038.              ) ) ) ) )
  6039. ) )     )  )
  6040.  
  6041. ; compiliere (OR {form}*)
  6042. (defun c-OR ()
  6043.   (test-list *form* 1)
  6044.   (cond ((null (cdr *form*)) ; keine Formen
  6045.          (make-anode
  6046.            :type 'OR
  6047.            :sub-anodes '()
  6048.            :seclass '(NIL . NIL)
  6049.            :code '((NIL))
  6050.         ))
  6051.         ((null (cddr *form*)) (c-form (second *form*))) ; genau eine Form
  6052.         (t (do (#+COMPILER-DEBUG (anodelist '())
  6053.                 (seclass '(NIL . NIL))
  6054.                 (codelist '())
  6055.                 (Lr (cdr *form*))
  6056.                 (label (make-label *for-value*))) ; Label am Ende
  6057.                ((null Lr)
  6058.                 (push label codelist)
  6059.                 (make-anode
  6060.                   :type 'OR
  6061.                   :sub-anodes (nreverse anodelist)
  6062.                   :seclass seclass
  6063.                   :code (nreverse codelist)
  6064.                ))
  6065.              (let* ((formi (pop Lr))
  6066.                     (anodei (c-form formi (if (null Lr) *for-value* 'ONE))))
  6067.                #+COMPILER-DEBUG (push anodei anodelist)
  6068.                (seclass-or-f seclass anodei)
  6069.                (if (null Lr)
  6070.                  ; letzte Form -> direkt ⁿbernehmen
  6071.                  (push anodei codelist)
  6072.                  ; nicht letzte Form -> Test kreieren
  6073.                  (if (anode-constantp anodei)
  6074.                    ; Konstante NIL -> weglassen, Konstante /= NIL -> fertig
  6075.                    (when (anode-constant-value anodei)
  6076.                      (if *for-value* (push anodei codelist))
  6077.                      (let ((*no-code* t)) (dolist (form Lr) (c-form form 'NIL)))
  6078.                      (setq Lr nil)
  6079.                    )
  6080.                    (progn ; normaler Test
  6081.                      (push anodei codelist)
  6082.                      (push `(,(if *for-value* 'JMPIF1 'JMPIF) ,label)
  6083.                            codelist
  6084.              ) ) ) ) )
  6085. ) )     )  )
  6086.  
  6087. ; compiliere (QUOTE object)
  6088. (defun c-QUOTE ()
  6089.   (test-list *form* 2 2)
  6090.   (let ((value (second *form*)))
  6091.     (make-anode :type 'QUOTE
  6092.                 :sub-anodes '()
  6093.                 :seclass '(NIL . NIL)
  6094.                 :code (if *for-value* `((CONST ,(new-const value))) '() )
  6095. ) ) )
  6096.  
  6097. ; compiliere (THE type form)
  6098. (defun c-THE ()
  6099.   (test-list *form* 3 3)
  6100.   (c-form (third *form*)) ; ignoriere einfach die Typdeklaration
  6101. )
  6102.  
  6103. ; compiliere (DECLARE {declspec}*)
  6104. (defun c-DECLARE ()
  6105.   (test-list *form* 1)
  6106.   (c-error (DEUTSCH "Deklarationen sind an dieser Stelle nicht erlaubt: ~S"
  6107.             ENGLISH "Misplaced declaration: ~S"
  6108.             FRANCAIS "Une dΘclaration n'est pas permise ici : ~S")
  6109.            *form*
  6110. ) )
  6111.  
  6112. ; compiliere (LOAD-TIME-VALUE form [read-only-p])
  6113. (defun c-LOAD-TIME-VALUE ()
  6114.   (test-list *form* 2 3)
  6115.   (let ((form (second *form*))) ; ignoriere read-only-p
  6116.     (make-anode :type 'LOAD-TIME-VALUE
  6117.                 :sub-anodes '()
  6118.                 :seclass '(NIL . NIL)
  6119.                 :code (if *for-value*
  6120.                         `((CONST ,(if *compiling-from-file*
  6121.                                     (if (and (symbolp form) (c-constantp form))
  6122.                                       (make-const :horizont ':all :value (c-constant-value form) :form form)
  6123.                                       (make-const :horizont ':form :form form)
  6124.                                     )
  6125.                                     (make-const :horizont ':all :value (eval form) :form form)
  6126.                                   )
  6127.                          ))
  6128.                         '()
  6129.                       )
  6130. ) ) )
  6131.  
  6132. ; compiliere (CATCH tag {form}*)
  6133. (defun c-CATCH ()
  6134.   (test-list *form* 2)
  6135.   (let* ((anode1 (c-form (second *form*) 'ONE))
  6136.          (anode2 (let ((*stackz* (cons 'CATCH *stackz*)))
  6137.                    (c-form `(PROGN ,@(cddr *form*)))
  6138.          )       )
  6139.          (label (make-label *for-value*)))
  6140.     (make-anode :type 'CATCH
  6141.                 :sub-anodes (list anode1 anode2)
  6142.                 :seclass (anodes-seclass-or anode1 anode2)
  6143.                 :code `(,anode1
  6144.                         (CATCH-OPEN ,label)
  6145.                         ,anode2
  6146.                         (CATCH-CLOSE)
  6147.                         ,label
  6148. ) ) )                  )
  6149.  
  6150. ; compiliere (THROW tag form)
  6151. (defun c-THROW ()
  6152.   (test-list *form* 3 3)
  6153.   (let* ((anode1 (c-form (second *form*) 'ONE))
  6154.          (anode2 (let ((*stackz* (cons 1 *stackz*)))
  6155.                    (c-form (third *form*) 'ALL)
  6156.         ))       )
  6157.     (make-anode :type 'THROW
  6158.                 :sub-anodes (list anode1 anode2)
  6159.                 :seclass (cons (car (anodes-seclass-or anode1 anode2)) 'T)
  6160.                 :code `(,anode1 (PUSH) ,anode2 (THROW))
  6161. ) ) )
  6162.  
  6163. ; compiliere (UNWIND-PROTECT form1 {form}*)
  6164. (defun c-UNWIND-PROTECT ()
  6165.   (test-list *form* 2)
  6166.   (let* ((anode1 (let ((*stackz* (cons 'UNWIND-PROTECT *stackz*)))
  6167.                    (c-form (second *form*))
  6168.          )       )
  6169.          (anode2 (let ((*stackz* (cons 'CLEANUP *stackz*)))
  6170.                    (c-form `(PROGN ,@(cddr *form*)) 'NIL)
  6171.          )       )
  6172.          (label (make-label 'NIL)))
  6173.     (make-anode :type 'UNWIND-PROTECT
  6174.                 :sub-anodes (list anode1 anode2)
  6175.                 :seclass (anodes-seclass-or anode1 anode2)
  6176.                 :code `((UNWIND-PROTECT-OPEN ,label)
  6177.                         ,anode1
  6178.                         ,@(case *for-value*
  6179.                             ((NIL) '((VALUES0)))
  6180.                             (ONE '((VALUES1)))
  6181.                             ((T) '())
  6182.                           )
  6183.                         (UNWIND-PROTECT-NORMAL-EXIT)
  6184.                         ,label
  6185.                         ,anode2
  6186.                         (UNWIND-PROTECT-CLOSE ,label)
  6187. ) ) )                  )
  6188.  
  6189. ; compiliere (PROGV form1 form2 {form}*)
  6190. (defun c-PROGV ()
  6191.   (test-list *form* 3)
  6192.   (let ((anode1 (c-form (second *form*) 'ONE)))
  6193.     ; falls form1 konstant=NIL ist, kann man sich das Binden sparen:
  6194.     (if (and (anode-constantp anode1) (null (anode-constant-value anode1)))
  6195.       (c-form `(PROGN ,(third *form*) (PROGN ,@(cdddr *form*))))
  6196.       (let* ((stackz2 (cons 1 *stackz*))
  6197.              (anode2 (let ((*stackz* stackz2))
  6198.                        (c-form (third *form*) 'ONE)
  6199.              )       )
  6200.              (stackz3 (cons 'PROGV *stackz*))
  6201.              (anode3 (let ((*stackz* stackz3))
  6202.                        (c-form `(PROGN ,@(cdddr *form*)))
  6203.              )       )
  6204.              (flag t))
  6205.         ; falls anode3 von keinen Seiteneffekten abhΣngig ist, kann man sich das
  6206.         ; Binden sparen:
  6207.         (when (null (car (anode-seclass anode3)))
  6208.           (setf (first stackz2) 0)
  6209.           (setf (first stackz3) 0)
  6210.           (setq flag nil)
  6211.         )
  6212.         (make-anode :type 'PROGV
  6213.                     :sub-anodes (list anode1 anode2 anode3)
  6214.                     :seclass (anodes-seclass-or anode1 anode2 anode3)
  6215.                     :code `(,anode1
  6216.                             ,@(if flag '((PUSH)))
  6217.                             ,anode2
  6218.                             ,@(if flag '((PROGV)))
  6219.                             ,anode3
  6220.                             ,@(if flag
  6221.                                 `((UNWIND ,stackz3 ,*stackz* ,*for-value*))
  6222.                                 ; wird expandiert zu '((UNBIND1) (SKIPSP 1 0))
  6223.                            )  )
  6224. ) ) ) ) )
  6225.  
  6226. ; compiliere (MULTIPLE-VALUE-PROG1 form1 {form}*)
  6227. ; falls Werte nicht gebraucht werden: einfaches PROGN. Sonst: falls {form}*
  6228. ; seiteneffektfrei, nur form1, sonst: Werte von form1 auf den Stack legen und
  6229. ; nachher mit Funktion VALUES wieder einsammeln.
  6230. (defun c-MULTIPLE-VALUE-PROG1 ()
  6231.   (test-list *form* 2)
  6232.   (case *for-value*
  6233.     (ALL
  6234.      (let* ((stackz1 (cons 'MVCALLP *stackz*))
  6235.             (anode1 (let ((*stackz* stackz1))
  6236.                       (c-form (second *form*))
  6237.             )       )
  6238.             (anode2 (let ((*stackz* (cons 'MVCALL *stackz*)))
  6239.                       (c-form `(PROGN ,@(cddr *form*)) 'NIL)
  6240.            ))       )
  6241.        (make-anode :type 'MULTIPLE-VALUE-PROG1
  6242.                    :sub-anodes (list anode1 anode2)
  6243.                    :seclass (anodes-seclass-or anode1 anode2)
  6244.                    :code
  6245.                       (if (cdr (anode-seclass anode2))
  6246.                         `((CONST , #+CLISP (make-const :horizont ':all
  6247.                                                        :value #'values
  6248.                                                        :form '(function values)
  6249.                                            )
  6250.                                    #-CLISP (new-const 'values)
  6251.                           )
  6252.                           (MVCALLP)
  6253.                           ,anode1
  6254.                           (MV-TO-STACK)
  6255.                           ,anode2
  6256.                           (MVCALL))
  6257.                         (prog2 (setf (first stackz1) 0) `(,anode1))
  6258.                       )
  6259.     )) )
  6260.     (ONE (c-form `(PROG1 ,@(cdr *form*))))
  6261.     ((NIL) (c-form `(PROGN ,@(cdr *form*))))
  6262. ) )
  6263.  
  6264. ; compiliere (MULTIPLE-VALUE-CALL form1 {form}*)
  6265. (defun c-MULTIPLE-VALUE-CALL ()
  6266.   (test-list *form* 2)
  6267.   (if (null (cddr *form*))
  6268.     ; (c-form `(SYS::%FUNCALL ,(second *form*))) ; 0 Argumente zu form1
  6269.     (c-FUNCTION-CALL (second *form*) '())
  6270.     (let* ((anode1 (c-form (second *form*) 'ONE))
  6271.            #+COMPILER-DEBUG (anodelist (list anode1))
  6272.            (codelist '()))
  6273.       (push anode1 codelist)
  6274.       (push '(MVCALLP) codelist)
  6275.       (do ((Lr (cddr *form*))
  6276.            (i 0 (1+ i)))
  6277.           ((null Lr))
  6278.         (let* ((formi (pop Lr))
  6279.                (anodei
  6280.                  (let ((*stackz* (cons (if (zerop i) 'MVCALLP 'MVCALL) *stackz*)))
  6281.                    (c-form formi 'ALL)
  6282.               )) )
  6283.           #+COMPILER-DEBUG (push anodei anodelist)
  6284.           (push anodei codelist)
  6285.           (push '(MV-TO-STACK) codelist)
  6286.       ) )
  6287.       (push '(MVCALL) codelist)
  6288.       (make-anode :type 'MULTIPLE-VALUE-CALL
  6289.                   :sub-anodes (nreverse anodelist)
  6290.                   :seclass '(T . T)
  6291.                   :code (nreverse codelist)
  6292. ) ) ) )
  6293.  
  6294. ; compiliere (MULTIPLE-VALUE-LIST form)
  6295. (defun c-MULTIPLE-VALUE-LIST ()
  6296.   (test-list *form* 2 2)
  6297.   (if *for-value*
  6298.     (let ((anode1 (c-form (second *form*) 'ALL)))
  6299.       (make-anode :type 'MULTIPLE-VALUE-LIST
  6300.                   :sub-anodes (list anode1)
  6301.                   :seclass (anodes-seclass-or anode1)
  6302.                   :code `(,anode1 (MV-TO-LIST))
  6303.     ) )
  6304.     (c-form (second *form*))
  6305. ) )
  6306.  
  6307. ; Stellt fest, ob eine SETQ-Argumentliste Symbol-Macros zuweist.
  6308. (defun setqlist-macrop (l)
  6309.   (do ((l l (cddr l)))
  6310.       ((null l) nil)
  6311.     (let ((s (car l)))
  6312.       (when (and (symbolp s) (venv-search-macro s)) (return t))
  6313. ) ) )
  6314.  
  6315. ; compiliere (SETQ {symbol form}*)
  6316. ; alle Zuweisungen nacheinander durchfⁿhren
  6317. (defun c-SETQ ()
  6318.   (test-list *form* 1)
  6319.   (when (evenp (length *form*))
  6320.     (c-error (DEUTSCH "Ungerade viele Argumente zu SETQ: ~S"
  6321.               ENGLISH "Odd number of arguments to SETQ: ~S"
  6322.               FRANCAIS "Nombre impair d'arguments pour SETQ : ~S")
  6323.              *form*
  6324.   ) )
  6325.   (if (null (cdr *form*))
  6326.     (c-NIL) ; (SETQ) == (PROGN) == NIL
  6327.     (if (setqlist-macrop (cdr *form*))
  6328.       (c-form ; (SETF ...) statt (SETQ ...), macroexpandieren
  6329.         (funcall (macro-function 'SETF) (cons 'SETF (cdr *form*))
  6330.                  (vector *venv* *fenv*)
  6331.       ) )
  6332.       (do ((L (cdr *form*) (cddr L))
  6333.            #+COMPILER-DEBUG (anodelist '())
  6334.            (seclass '(NIL . NIL))
  6335.            (codelist '()))
  6336.           ((null L)
  6337.            (make-anode
  6338.              :type 'SETQ
  6339.              :sub-anodes (nreverse anodelist)
  6340.              :seclass seclass
  6341.              :code (nreverse codelist)
  6342.           ))
  6343.         (let* ((symboli (first L))
  6344.                (formi (second L))
  6345.                (anodei (c-form formi 'ONE)))
  6346.           #+COMPILER-DEBUG (push anodei anodelist)
  6347.           (if (symbolp symboli)
  6348.             (progn
  6349.               (push anodei codelist)
  6350.               (seclass-or-f seclass anodei)
  6351.               (let ((setteri (c-VARSET symboli anodei
  6352.                                        (and *for-value* (null (cddr L)))
  6353.                    ))        )
  6354.                 (push setteri codelist)
  6355.                 (seclass-or-f seclass setteri)
  6356.             ) )
  6357.             (progn
  6358.               (catch 'c-error
  6359.                 (c-error (DEUTSCH "Zuweisung auf ~S unm÷glich, da kein Symbol."
  6360.                           ENGLISH "Cannot assign to non-symbol ~S."
  6361.                           FRANCAIS "Rien ne peut Ωtre assignΘ α ~S car ce n'est pas un symbole.")
  6362.                          symboli
  6363.               ) )
  6364.               (push '(VALUES1) codelist)
  6365.       ) ) ) )
  6366. ) ) )
  6367.  
  6368. ; compiliere (PSETQ {symbol form}*)
  6369. ; alle Zwischenwerte auf dem Stack retten, erst dann zuweisen
  6370. (defun c-PSETQ ()
  6371.   (test-list *form* 1)
  6372.   (when (evenp (length *form*))
  6373.     (c-error (DEUTSCH "Ungerade viele Argumente zu PSETQ: ~S"
  6374.               ENGLISH "Odd number of arguments to PSETQ: ~S"
  6375.               FRANCAIS "Nombre impair d'arguments pour PSETQ : ~S")
  6376.              *form*
  6377.   ) )
  6378.   (if (null (cdr *form*))
  6379.     (c-NIL) ; (PSETQ) == (PROGN) == NIL
  6380.     (if (setqlist-macrop (cdr *form*))
  6381.       (c-form ; (PSETF ...) statt (PSETQ ...), macroexpandieren
  6382.         (funcall (macro-function 'PSETF) (cons 'PSETF (cdr *form*))
  6383.                  (vector *venv* *fenv*)
  6384.       ) )
  6385.       (let ((anodelist '())
  6386.             (setterlist '()))
  6387.         ; Formen und Zuweisungen compilieren:
  6388.         (do ((L (cdr *form*)))
  6389.             ((null L))
  6390.           (let* ((symboli (pop L))
  6391.                  (formi (pop L))
  6392.                  (anodei (c-form formi 'ONE)))
  6393.             (if (symbolp symboli)
  6394.               (progn
  6395.                 (push anodei anodelist)
  6396.                 (push (c-VARSET symboli anodei nil) setterlist)
  6397.                 (push 0 *stackz*)
  6398.               )
  6399.               (catch 'c-error
  6400.                 (c-error (DEUTSCH "Zuweisung auf ~S unm÷glich, da kein Symbol."
  6401.                           ENGLISH "Cannot assign to non-symbol ~S."
  6402.                           FRANCAIS "Rien ne peut Ωtre assignΘ α ~S car ce n'est pas un symbole.")
  6403.                          symboli
  6404.         ) ) ) ) )
  6405.         ; Versuche, sie so zu reorganisieren, da▀ m÷glichst wenige (PUSH)
  6406.         ; und (POP) n÷tig werden:
  6407.         (let ((codelist1 '())
  6408.               (codelist2 '())
  6409.               ; baue codelist = (nconc codelist1 (nreverse codelist2)) zusammen
  6410.               (seclass '(NIL . NIL))) ; Seiteneffektklasse von codelist insgesamt
  6411.           (do ((anodelistr anodelist (cdr anodelistr))
  6412.                (setterlistr setterlist (cdr setterlistr)))
  6413.               ((null anodelistr))
  6414.             (let ((anode (car anodelistr))
  6415.                   (setter (car setterlistr)))
  6416.               ; Normalerweise wΣre vor codelist der anode und ein (PUSH)
  6417.               ; und nach codelist ein (POP) und der setter anzuhΣngen.
  6418.               ; Dies versuchen wir zu vereinfachen:
  6419.               (cond ((seclasses-commute (anode-seclass setter) seclass)
  6420.                      ; Ziehe den setter nach vorne:
  6421.                      (push setter codelist1)
  6422.                      (push anode codelist1)
  6423.                     )
  6424.                     ((seclasses-commute (anode-seclass anode) seclass)
  6425.                      ; Ziehe den anode nach hinten:
  6426.                      (push anode codelist2)
  6427.                      (push setter codelist2)
  6428.                     )
  6429.                     (t ; keine Vereinfachung m÷glich
  6430.                      (push '(PUSH) codelist1)
  6431.                      (push anode codelist1)
  6432.                      (push '(POP) codelist2)
  6433.                      (push setter codelist2)
  6434.                      (setf (car *stackz*) 1) ; brauche eine Variable im Stack
  6435.               )     )
  6436.               (setq seclass
  6437.                 (seclass-or-2 seclass
  6438.                   (seclass-or-2 (anode-seclass anode) (anode-seclass setter))
  6439.               ) )
  6440.               (setf *stackz* (cdr *stackz*))
  6441.           ) )
  6442.           ; *stackz* ist nun wieder auf dem alten Niveau.
  6443.           (when *for-value* (push '(NIL) codelist2))
  6444.           (make-anode
  6445.             :type 'PSETQ
  6446.             :sub-anodes (nreverse anodelist)
  6447.             :seclass seclass
  6448.             :code (nconc codelist1 (nreverse codelist2))
  6449. ) ) ) ) ) )
  6450.  
  6451. ; compiliere (MULTIPLE-VALUE-SETQ ({symbol}*) form)
  6452. ; alle gewⁿnschten Werte auf den Stack, dann einzeln herunternehmen und
  6453. ; zuweisen.
  6454. (defun c-MULTIPLE-VALUE-SETQ ()
  6455.   (test-list *form* 3 3)
  6456.   (test-list (second *form*) 0)
  6457.   (if (dolist (s (second *form*) nil)
  6458.         (when (and (symbolp s) (venv-search-macro s)) (return t))
  6459.       )
  6460.     (c-form `(SYSTEM::MULTIPLE-VALUE-SETF ,@(cdr *form*)))
  6461.     (let* ((n (length (second *form*)))
  6462.            (anode1 (c-form (third *form*) 'ALL))
  6463.            (*stackz* *stackz*))
  6464.       (if (zerop n)
  6465.         (make-anode :type 'MULTIPLE-VALUE-SETQ
  6466.                     :sub-anodes (list anode1)
  6467.                     :seclass (anodes-seclass-or anode1)
  6468.                     :code `(,anode1
  6469.                             ,@(if (eq *for-value* 'ALL) '((VALUES1)) '())
  6470.         )                  )
  6471.         (do ((L (second *form*) (cdr L))
  6472.              #+COMPILER-DEBUG (anodelist (list anode1))
  6473.              (seclass (anode-seclass anode1))
  6474.              (codelist '()))
  6475.             ((null L)
  6476.              (if (= n 1)
  6477.                (setq codelist (cdr codelist)) ; letztes (POP) streichen
  6478.                (setq codelist (cons `(NV-TO-STACK ,n) codelist))
  6479.              )
  6480.              (make-anode
  6481.                :type 'MULTIPLE-VALUE-SETQ
  6482.                :sub-anodes (nreverse anodelist)
  6483.                :seclass seclass
  6484.                :code (cons anode1 codelist)
  6485.             ))
  6486.           (let ((symbol (car L)))
  6487.             (if (symbolp symbol)
  6488.               (let ((setter (c-VARSET symbol
  6489.                               (make-anode :type 'NOP
  6490.                                           :sub-anodes '()
  6491.                                           :seclass '(NIL . NIL)
  6492.                                           :code '()
  6493.                               )
  6494.                               (and *for-value* (null codelist))
  6495.                    ))       )
  6496.                 (push setter codelist)
  6497.                 (seclass-or-f seclass setter)
  6498.               )
  6499.               (catch 'c-error
  6500.                 (c-error (DEUTSCH "Zuweisung auf ~S unm÷glich, da kein Symbol."
  6501.                           ENGLISH "Cannot assign to non-symbol ~S."
  6502.                           FRANCAIS "Rien ne peut Ωtre assignΘ α ~S car ce n'est pas un symbole.")
  6503.                          symbol
  6504.           ) ) ) )
  6505.           (push '(POP) codelist)
  6506.           (push 1 *stackz*)
  6507. ) ) ) ) )
  6508.  
  6509. ; Liefert den Code fⁿr das parallele Binden von Variablen.
  6510. ; (car *stackz*) sollte = 0 sein, (cdr *stackz*) wird evtl. erweitert.
  6511. (defun c-parallel-bind-movable-var-anode (varlist anodelist stackzlist
  6512.                                           &optional (other-anodes '())
  6513.                                          )
  6514.   ; Variable darf erst am Schlu▀ gebunden werden, falls sie SPECIAL ist
  6515.   ; und nachfolgende Anodes von ihrem Wert abhΣngen k÷nnen.
  6516.   (let ((bind-afterwards nil))
  6517.     (append
  6518.       (maplap
  6519.         #'(lambda (varlistr anodelistr stackzlistr)
  6520.             (let ((var (car varlistr))
  6521.                   (anode (car anodelistr)))
  6522.               (if (and (var-specialp var)
  6523.                        (let ((symbol (var-name var)))
  6524.                          (some
  6525.                            #'(lambda (other-anode)
  6526.                                ; hΣngt der Wert von other-anode m÷glicherweise
  6527.                                ; vom Wert von var ab?
  6528.                                (let ((uses (car (anode-seclass other-anode))))
  6529.                                  (or (eq uses 'T) (member symbol uses))
  6530.                              ) )
  6531.                            (cdr anodelistr)
  6532.                   )    ) )
  6533.                 (let* ((stackz (car stackzlistr))
  6534.                        (dummyvar ; Hilfsvariable im Stack
  6535.                          (make-var :name (gensym) :specialp nil
  6536.                                    :closurep nil :stackz stackz
  6537.                       )) )
  6538.                   (push (list dummyvar var (cdr *stackz*)) bind-afterwards)
  6539.                   (push (car stackz) (cdr *stackz*)) ; Platz fⁿr 1 Schlu▀-Bindung mehr
  6540.                   (setf (car stackz) 1) ; Platz fⁿr Hilfsvariable im Stack merken
  6541.                   (c-bind-movable-var-anode dummyvar anode)
  6542.                 )
  6543.                 (c-bind-movable-var-anode var anode)
  6544.           ) ) )
  6545.         varlist (append anodelist other-anodes) stackzlist
  6546.       )
  6547.       other-anodes
  6548.       (mapcap
  6549.         #'(lambda (bind)
  6550.             (let ((dummyvar (first bind)) ; Hilfsvariable im Stack
  6551.                   (var (second bind)) ; SPECIAL-Variable
  6552.                   (stackz (third bind))) ; Stackzustand vor Aufbau der Schlu▀-Bindung
  6553.               `((GET ,dummyvar ,*venvc* ,stackz)
  6554.                 ,@(c-bind-movable-var var)
  6555.                )
  6556.           ) )
  6557.         (nreverse bind-afterwards)
  6558.       )
  6559.     )
  6560. ) )
  6561.  
  6562. ; compiliere (LET/LET* ({var|(var value)}*) {declaration}* {form}*)
  6563. (defun c-LET/LET* (*-flag)
  6564.   (test-list *form* 2)
  6565.   (test-list (second *form*) 0)
  6566.   (multiple-value-bind (body-rest declarations)
  6567.       (parse-body (cddr *form*) nil (vector *venv* *fenv*))
  6568.     (let ((oldstackz *stackz*)
  6569.           (*stackz* *stackz*)
  6570.           (*denv* *denv*)
  6571.           (*venv* *venv*)
  6572.           (*venvc* *venvc*))
  6573.       (multiple-value-bind (*specials* *ignores* *ignorables*)
  6574.           (process-declarations declarations)
  6575.         ; Special-Variable auf *venv* pushen:
  6576.         (push-specials)
  6577.         ; Syntaxtest der Parameterliste:
  6578.         (multiple-value-bind (symbols initforms) (analyze-letlist (second *form*))
  6579.           (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  6580.           (let ((closuredummy-stackz *stackz*)
  6581.                 (closuredummy-venvc *venvc*))
  6582.             (multiple-value-bind (varlist anodelist stackzlist)
  6583.                 (process-movable-var-list symbols initforms *-flag)
  6584.               (unless *-flag (push 0 *stackz*)) ; Platz fⁿr Schlu▀-Bindungen
  6585.               (let ((body-anode (c-form `(PROGN ,@body-rest)))) ; Body compilieren
  6586.                 ; ▄berprⁿfen der Variablen:
  6587.                 (let* ((closurevars (checking-movable-var-list varlist anodelist))
  6588.                        (codelist
  6589.                          `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  6590.                            ,@(if *-flag
  6591.                                ; sequentielles Binden der Variablen
  6592.                                (mapcap #'c-bind-movable-var-anode varlist anodelist)
  6593.                                ; paralleles Binden der Variablen
  6594.                                (c-parallel-bind-movable-var-anode varlist anodelist stackzlist)
  6595.                              )
  6596.                            ,body-anode
  6597.                            (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  6598.                        )  )
  6599.                        (anode
  6600.                          (make-anode
  6601.                            :type (if *-flag 'LET* 'LET)
  6602.                            :sub-anodes `(,@anodelist ,body-anode)
  6603.                            :seclass (seclass-without
  6604.                                       (anodelist-seclass-or `(,@anodelist ,body-anode))
  6605.                                       varlist
  6606.                                     )
  6607.                            :stackz oldstackz
  6608.                            :code codelist
  6609.                       )) )
  6610.                   (when closurevars
  6611.                     (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  6612.                     (setf (first closuredummy-venvc)
  6613.                       (cons closurevars closuredummy-stackz)
  6614.                   ) )
  6615.                   (optimize-var-list varlist)
  6616.                   anode
  6617. ) ) ) ) ) ) ) ) )
  6618.  
  6619. ; compiliere (LOCALLY {declaration}* {form}*)
  6620. (defun c-LOCALLY (&optional (c #'c-form)) ; vgl. c-LET/LET*
  6621.   (test-list *form* 1)
  6622.   (multiple-value-bind (body-rest declarations)
  6623.       (parse-body (cdr *form*) nil (vector *venv* *fenv*))
  6624.     (let ((*venv* *venv*))
  6625.       (multiple-value-bind (*specials* ignores ignorables)
  6626.           (process-declarations declarations)
  6627.         (declare (ignore ignores ignorables))
  6628.         ; Special-Variable auf *venv* pushen:
  6629.         (push-specials)
  6630.         (funcall c `(PROGN ,@body-rest))
  6631. ) ) ) )
  6632.  
  6633. ; compiliere (MULTIPLE-VALUE-BIND ({var}*) form1 {declaration}* {form}*)
  6634. (defun c-MULTIPLE-VALUE-BIND ()
  6635.   (test-list *form* 3)
  6636.   (test-list (second *form*) 0)
  6637.   (let ((symbols (second *form*)))
  6638.     (dolist (sym symbols)
  6639.       (unless (symbolp sym)
  6640.         (c-error (DEUTSCH "Nur Symbole k÷nnen Variable sein, nicht ~S"
  6641.                   ENGLISH "Only symbols may be used as variables, not ~S"
  6642.                   FRANCAIS "Seuls les symboles peuvent servir de variable et non ~S")
  6643.                  sym
  6644.     ) ) )
  6645.     (if (= (length symbols) 1)
  6646.       (c-form `(LET ((,(first symbols) ,(third *form*))) ,@(cdddr *form*)))
  6647.       (multiple-value-bind (body-rest declarations)
  6648.           (parse-body (cdddr *form*) nil (vector *venv* *fenv*))
  6649.         (let ((oldstackz *stackz*)
  6650.               (*stackz* *stackz*)
  6651.               (*denv* *denv*)
  6652.               (*venv* *venv*)
  6653.               (*venvc* *venvc*))
  6654.           (multiple-value-bind (*specials* *ignores* *ignorables*)
  6655.               (process-declarations declarations)
  6656.             ; Special-Variable auf *venv* pushen:
  6657.             (push-specials)
  6658.             (if (null symbols) ; leere Variablenliste -> gar nichts binden
  6659.               (let* ((anode1 (c-form (third *form*) 'NIL))
  6660.                      (anode2 (c-form `(PROGN ,@(cdddr *form*)))))
  6661.                 (make-anode :type 'MULTIPLE-VALUE-BIND
  6662.                   :sub-anodes (list anode1 anode2)
  6663.                   :seclass (anodes-seclass-or anode1 anode2)
  6664.                   :code `(,anode1 ,anode2)
  6665.               ) )
  6666.               (let ((anode1 (c-form (third *form*) 'ALL)))
  6667.                 (push nil *venvc*) ; Sichtbarkeit von Closure-Dummyvar
  6668.                 (multiple-value-bind (varlist stackvarlist)
  6669.                     (process-fixed-var-list symbols)
  6670.                   (push 0 *stackz*) ; Platz fⁿr Closure-Dummyvar
  6671.                   (let* ((closuredummy-stackz *stackz*)
  6672.                          (closuredummy-venvc *venvc*)
  6673.                          (stackzlist
  6674.                            (do* ((varlistr varlist (cdr varlistr))
  6675.                                  (L '()))
  6676.                                 ((null varlistr) (nreverse L))
  6677.                              (let ((var (car varlistr)))
  6678.                                (push-*venv* var)
  6679.                                (push *stackz* L) (bind-fixed-var-2 var)
  6680.                          ) ) )
  6681.                          (body-anode ; Body compilieren
  6682.                            (c-form `(PROGN ,@body-rest))
  6683.                          )
  6684.                          ; ▄berprⁿfen der Variablen:
  6685.                          (closurevars (checking-fixed-var-list varlist))
  6686.                          (codelist ; Code generieren
  6687.                            `(,anode1
  6688.                              (NV-TO-STACK ,(length symbols))
  6689.                              ,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  6690.                              ,@ ; Binden von special- oder Closure-Variablen:
  6691.                                (do ((stackvarlistr stackvarlist (cdr stackvarlistr))
  6692.                                     (stackzlistr stackzlist (cdr stackzlistr))
  6693.                                     (varlistr varlist (cdr varlistr))
  6694.                                     (L '()))
  6695.                                    ((null varlistr) (nreverse L))
  6696.                                  (setq L
  6697.                                    (append
  6698.                                      (reverse
  6699.                                        (c-bind-fixed-var
  6700.                                          (car varlistr)
  6701.                                          (car stackvarlistr)
  6702.                                          (car stackzlistr)
  6703.                                      ) )
  6704.                                      L
  6705.                                ) ) )
  6706.                              ,body-anode
  6707.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  6708.                          )  )
  6709.                          (anode
  6710.                            (make-anode
  6711.                              :type 'MULTIPLE-VALUE-BIND
  6712.                              :sub-anodes (list anode1 body-anode)
  6713.                              :seclass (seclass-without
  6714.                                         (anodes-seclass-or anode1 body-anode)
  6715.                                         varlist
  6716.                                       )
  6717.                              :stackz oldstackz
  6718.                              :code codelist
  6719.                         )) )
  6720.                     (when closurevars
  6721.                       (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  6722.                       (setf (first closuredummy-venvc)
  6723.                         (cons closurevars closuredummy-stackz)
  6724.                     ) )
  6725.                     (optimize-var-list varlist)
  6726.                     anode
  6727. ) ) ) ) ) ) ) ) ) )
  6728.  
  6729. ; compiliere (COMPILER-LET ({var|(var value)}*) {form}*)
  6730. (defun c-COMPILER-LET (&optional (c #'c-form))
  6731.   (test-list *form* 2)
  6732.   (test-list (second *form*) 0)
  6733.   (do ((L (second *form*) (cdr L))
  6734.        (varlist '())
  6735.        (valueslist '()))
  6736.       ((null L)
  6737.        (progv (nreverse varlist) (nreverse valueslist)
  6738.          (funcall c `(PROGN ,@(cddr *form*)) )
  6739.       ))
  6740.     (cond ((symbolp (car L)) (push (car L) varlist) (push nil valueslist))
  6741.           ((and (consp (car L)) (symbolp (caar L)) (consp (cdar L)) (null (cddar L)))
  6742.            (push (caar L) varlist) (push (eval (cadar L)) valueslist))
  6743.           (t (catch 'c-error
  6744.                (c-error (DEUTSCH "Falsche Syntax in COMPILER-LET: ~S"
  6745.                          ENGLISH "Illegal syntax in COMPILER-LET: ~S"
  6746.                          FRANCAIS "Mauvaise syntaxe pour COMPILER-LET : ~S")
  6747.                         (car L)
  6748.     )     )  ) )
  6749. ) )
  6750.  
  6751. (macrolet ((check-blockname (name)
  6752.              `(unless (symbolp ,name)
  6753.                 (catch 'c-error
  6754.                   (c-error (DEUTSCH "Blockname mu▀ ein Symbol sein, nicht ~S"
  6755.                             ENGLISH "Block name must be a symbol, not ~S"
  6756.                             FRANCAIS "Un nom de bloc doit Ωtre un symbole et non ~S")
  6757.                            ,name
  6758.                 ) )
  6759.                 (setq ,name NIL) ; Default-Blockname
  6760.               )
  6761.           ))
  6762.  
  6763. ; compiliere (BLOCK name {form}*)
  6764. (defun c-BLOCK ()
  6765.   (test-list *form* 2)
  6766.   (let ((name (second *form*)))
  6767.     (check-blockname name)
  6768.     (let* ((*stackz* (cons 'BLOCK *stackz*)) ; Block-Frame
  6769.            (label (make-label *for-value*))
  6770.            (block (make-block :fnode *func* :label label
  6771.                     :consvar (make-var :name (gensym) :specialp nil
  6772.                                        :closurep nil :stackz *stackz*
  6773.                              )
  6774.                     :stackz *stackz* :used-far nil :for-value *for-value*
  6775.            )      )
  6776.            (*benv* (cons (cons name block) *benv*)) ; Block aktivieren
  6777.            (anode (c-form `(PROGN ,@(cddr *form*))))
  6778.           )
  6779.       (if (block-used-far block)
  6780.         (make-anode :type 'BLOCK
  6781.                     :sub-anodes (list anode)
  6782.                     :seclass (anodes-seclass-or anode)
  6783.                     :code `((BLOCK-OPEN ,(new-const (and (symbol-package name) name)) ; (gensym) zu nil machen
  6784.                                         ,label
  6785.                             )
  6786.                             ,anode
  6787.                             (BLOCK-CLOSE)
  6788.                             ,label
  6789.         )                  )
  6790.         (progn
  6791.           (setf (first *stackz*) 0) ; brauche keinen Blockframe
  6792.           (make-anode :type 'BLOCK
  6793.                       :sub-anodes (list anode)
  6794.                       :seclass (anodes-seclass-or anode)
  6795.                       :code `(,anode ,label)
  6796. ) ) ) ) ) )
  6797.  
  6798. ; compiliere (RETURN-FROM name [form])
  6799. (defun c-RETURN-FROM ()
  6800.   (test-list *form* 2 3)
  6801.   (let ((name (second *form*)))
  6802.     (check-blockname name)
  6803.     (let ((a (benv-search name)))
  6804.       (cond ((null a) ; dieser Blockname ist unsichtbar
  6805.              (c-error (DEUTSCH "RETURN-FROM auf Block ~S an dieser Stelle nicht m÷glich."
  6806.                        ENGLISH "RETURN-FROM block ~S is impossible from here."
  6807.                        FRANCAIS "RETURN-FROM bloc ~S est impossible α partir d'ici.")
  6808.                       name
  6809.             ))
  6810.             ((block-p a) ; in *benv* ohne %benv% sichtbar
  6811.              (let ((anode (c-form (third *form*) (block-for-value a))))
  6812.                (if (and (eq (block-fnode a) *func*)
  6813.                         (may-UNWIND *stackz* (cdr (block-stackz a)))
  6814.                    )
  6815.                  ; selbe Funktionen
  6816.                  (make-anode
  6817.                    :type 'RETURN-FROM
  6818.                    :sub-anodes (list anode)
  6819.                    :seclass '(T . T)
  6820.                    :code `(,anode
  6821.                            (UNWIND ,*stackz* ,(cdr (block-stackz a)) ,(block-for-value a))
  6822.                            (JMP ,(block-label a))
  6823.                  )        )
  6824.                  ; verschiedene Funktionen oder unbekannte Frames auf dem Stack
  6825.                  (progn
  6826.                    (unless *no-code*
  6827.                      ; in alle dazwischenliegenden Funktionen diesen Block eintragen:
  6828.                      (do ((fnode *func* (fnode-enclosing fnode)))
  6829.                          ((eq fnode (block-fnode a)))
  6830.                        (pushnew a (fnode-blocks fnode))
  6831.                      )
  6832.                      (setf (block-used-far a) t)
  6833.                    )
  6834.                    (make-anode
  6835.                      :type 'RETURN-FROM
  6836.                      :sub-anodes (list anode)
  6837.                      :seclass '(T . T)
  6838.                      :code `(,anode
  6839.                              ,@(if (not (block-for-value a)) '((VALUES0)))
  6840.                              (RETURN-FROM ,a
  6841.                               ,@(if (eq (block-fnode a) *func*) `(,*stackz*) '())
  6842.                    )        ))
  6843.             )) ) )
  6844.             ((consp a) ; in %benv% sichtbar
  6845.              (let ((anode (c-form (third *form*) 'ALL)))
  6846.                (make-anode
  6847.                  :type 'RETURN-FROM
  6848.                  :sub-anodes (list anode)
  6849.                  :seclass '(T . T)
  6850.                  :code `(,anode
  6851.                          (RETURN-FROM ,(new-const a))
  6852.             )) )        )
  6853.             (t (compiler-error 'c-RETURN-FROM))
  6854. ) ) ) )
  6855.  
  6856. ) ; macrolet
  6857.  
  6858. ; compiliere (TAGBODY {tag|form}*)
  6859. (defun c-TAGBODY ()
  6860.   (test-list *form* 1)
  6861.   (multiple-value-bind (taglist labellist)
  6862.     (do ((L (cdr *form*) (cdr L))
  6863.          (taglist '())
  6864.          (labellist '()))
  6865.         ((null L) (values (nreverse taglist) (nreverse labellist)))
  6866.       (let ((item (car L)))
  6867.         (if (atom item)
  6868.           (if (or (and (symbolp item) (not (null item))) (numberp item))
  6869.             ; Symbol NIL wird ausgeschlossen, weil zweideutig (ist auch Liste!).
  6870.             ; Andere Zahlen werden zugelassen, damit - ebenso wie 3.3.2 - auch
  6871.             ; 3.3 ein zulΣssiges Sprungziel ist.
  6872.             (progn
  6873.               (push item taglist)
  6874.               (push (make-label 'NIL) labellist)
  6875.             )
  6876.             (catch 'c-error
  6877.               (c-error (DEUTSCH "Nur Zahlen und Symbole sind zulΣssige Sprungziele, nicht aber ~S"
  6878.                         ENGLISH "Only numbers and symbols are valid tags, not ~S"
  6879.                         FRANCAIS "Seuls les symboles et les nombres peuvent servir de marqueur de saut et non ~S")
  6880.                        item
  6881.     ) ) ) ) ) )
  6882.     (let* ((*stackz* (cons 0 *stackz*)) ; evtl. TAGBODY-Frame
  6883.            (tagbody (make-tagbody :fnode *func* :labellist labellist
  6884.                       :consvar (make-var :name (gensym) :specialp nil
  6885.                                          :closurep nil :stackz *stackz*
  6886.                                )
  6887.                       :stackz *stackz*
  6888.                       :used-far (make-array (length taglist) :fill-pointer 0)
  6889.            )        )
  6890.            (*genv* (cons (cons (apply #'vector taglist) tagbody) *genv*))
  6891.              ; Tagbody aktivieren
  6892.            (codelist '())
  6893.            #+COMPILER-DEBUG (anodelist '())
  6894.            (seclass '(NIL . NIL)))
  6895.       ; Inneres des Tagbody compilieren:
  6896.       (do ((formlistr (cdr *form*) (cdr formlistr))
  6897.            (taglistr taglist)
  6898.            (labellistr labellist))
  6899.           ((null formlistr)
  6900.            #+COMPILER-DEBUG (setq anodelist (nreverse anodelist))
  6901.            (setq codelist (nreverse codelist))
  6902.           )
  6903.         (let ((formi (car formlistr)))
  6904.           (if (atom formi)
  6905.             (when (and (consp taglistr) (eql formi (car taglistr)))
  6906.               ; Tag wiedergefunden
  6907.               (pop taglistr) (push (pop labellistr) codelist)
  6908.             )
  6909.             (let ((anodei (c-form formi 'NIL)))
  6910.               #+COMPILER-DEBUG (push anodei anodelist)
  6911.               (seclass-or-f seclass anodei)
  6912.               (push anodei codelist)
  6913.       ) ) ) )
  6914.       (if (> (length (tagbody-used-far tagbody)) 0)
  6915.         (let* ((used-tags (tagbody-used-far tagbody))
  6916.                (l (length used-tags))
  6917.                (used-label-list
  6918.                  (do ((i 0 (1+ i))
  6919.                       (l1 '()))
  6920.                      ((= i l) (nreverse l1))
  6921.                    (push
  6922.                      (elt labellist (position (aref used-tags i) taglist :test #'eql))
  6923.                      l1
  6924.               )) ) )
  6925.           (setf (first *stackz*) `(TAGBODY ,l))
  6926.           (setq codelist
  6927.             `((TAGBODY-OPEN
  6928.                 ,(new-const (map 'simple-vector
  6929.                                  #'(lambda (tag) (and (symbol-package tag) tag)) ; (gensym)s zu nil machen
  6930.                                  used-tags
  6931.                  )          )
  6932.                 ,@used-label-list
  6933.               )
  6934.               ,@codelist
  6935.               (TAGBODY-CLOSE-NIL)
  6936.         ) )  )
  6937.         (when *for-value* (setq codelist `(,@codelist (NIL))))
  6938.       )
  6939.       (make-anode :type 'TAGBODY
  6940.                   :sub-anodes anodelist
  6941.                   :seclass seclass
  6942.                   :code codelist
  6943. ) ) ) )
  6944.  
  6945. ; compiliere (GO tag)
  6946. (defun c-GO ()
  6947.   (test-list *form* 2 2)
  6948.   (let ((tag (second *form*)))
  6949.     (unless (or (and (symbolp tag) (not (null tag))) (numberp tag))
  6950.       (c-error (DEUTSCH "Sprungziel mu▀ ein Symbol oder eine Zahl sein, nicht ~S"
  6951.                 ENGLISH "Tag must be a symbol or a number, not ~S"
  6952.                 FRANCAIS "Le marqueur de saut doit Ωtre un symbole ou un nombre et non ~S")
  6953.                tag
  6954.     ) )
  6955.     (multiple-value-bind (a b) (genv-search tag)
  6956.       (cond ((null a) ; dieser Tag ist unsichtbar
  6957.              (c-error (DEUTSCH "GO auf Tag ~S an dieser Stelle nicht m÷glich."
  6958.                        ENGLISH "GO to tag ~S is impossible from here."
  6959.                        FRANCAIS "GO vers le marqueur ~S n'est pas possible ici.")
  6960.                       tag
  6961.             ))
  6962.             ((tagbody-p a) ; in *genv* ohne %genv% sichtbar
  6963.              (if (and (eq (tagbody-fnode a) *func*)
  6964.                       (may-UNWIND *stackz* (tagbody-stackz a))
  6965.                  )
  6966.                ; selbe Funktionen
  6967.                (make-anode
  6968.                  :type 'GO
  6969.                  :sub-anodes '()
  6970.                  :seclass '(T . T)
  6971.                  :code `((UNWIND ,*stackz* ,(tagbody-stackz a) nil)
  6972.                          (JMP ,(nth b (tagbody-labellist a)))
  6973.                )        )
  6974.                ; verschiedene Funktionen oder unbekannte Frames auf dem Stack
  6975.                (let ((index 0))
  6976.                  (unless *no-code*
  6977.                    (setq index
  6978.                      (do* ((v (tagbody-used-far a))
  6979.                            (l (length v))
  6980.                            (i 0 (1+ i)))
  6981.                           ((= i l) (vector-push tag v) l)
  6982.                        (if (eql (aref v i) tag) (return i))
  6983.                    ) )
  6984.                    ; (aref (tagbody-used-far a) index) = tag
  6985.                    ; in alle dazwischenliegenden Funktionen diesen Tagbody eintragen:
  6986.                    (do ((fnode *func* (fnode-enclosing fnode)))
  6987.                        ((eq fnode (tagbody-fnode a)))
  6988.                      (pushnew a (fnode-tagbodys fnode))
  6989.                  ) )
  6990.                  (make-anode
  6991.                    :type 'GO
  6992.                    :sub-anodes '()
  6993.                    :seclass '(T . T)
  6994.                    :code `((VALUES0)
  6995.                            (GO ,a ,index
  6996.                             ,@(if (eq (tagbody-fnode a) *func*) `(,*stackz*) '())
  6997.                           ))
  6998.                  )
  6999.             )) )
  7000.             ((consp a) ; in %genv% sichtbar
  7001.              (make-anode
  7002.                :type 'GO
  7003.                :sub-anodes '()
  7004.                :seclass '(T . T)
  7005.                :code `((GO ,(new-const a) ,b))
  7006.             ))
  7007.             (t (compiler-error 'c-GO))
  7008. ) ) ) )
  7009.  
  7010. ; compiliere (FUNCTION funname)
  7011. (defun c-FUNCTION ()
  7012.   (test-list *form* 2 3)
  7013.   (let* ((longp (cddr *form*)) ; Flag, ob Langform (FUNCTION name funname)
  7014.          (name (second *form*)))
  7015.     (if (and (not longp) (function-name-p name))
  7016.       (multiple-value-bind (a b c) (fenv-search name)
  7017.         (case a
  7018.           ((NIL)
  7019.            (when *compiling-from-file* ; von COMPILE-FILE aufgerufen?
  7020.              (unless (or (fboundp name) (member name *known-functions* :test #'equal))
  7021.                (pushnew name *unknown-functions* :test #'equal)
  7022.            ) )
  7023.            (make-anode
  7024.              :type 'FUNCTION
  7025.              :sub-anodes '()
  7026.              :seclass '(T . NIL)
  7027.              :code (if (and (subr-info name) (not (declared-notinline name)))
  7028.                      `((CONST ,(make-const :horizont ':all
  7029.                                            :value (symbol-function name)
  7030.                                            :form `(FUNCTION ,name)
  7031.                       ))       )
  7032.                      `((CONST ,(make-funname-const name)) (SYMBOL-FUNCTION))
  7033.           ))       )
  7034.           (SYSTEM::MACRO
  7035.            (c-error (DEUTSCH "~S ist keine Funktion, sondern ein lokal definierter Macro."
  7036.                      ENGLISH "~S is not a function. It is a locally defined macro."
  7037.                      FRANCAIS "~S n'est pas une fonction mais une macro dΘfinie localement.")
  7038.                     name
  7039.           ))
  7040.           (GLOBAL ; gefunden in %fenv%
  7041.            (make-anode
  7042.              :type 'FUNCTION
  7043.              :sub-anodes '()
  7044.              :seclass '(T . NIL)
  7045.              :code `((CONST ,(new-const b))
  7046.                      (PUSH)
  7047.                      (CONST ,(new-const c))
  7048.                      (SVREF)
  7049.           ))        )
  7050.           (LOCAL ; gefunden in *fenv* ohne %fenv%
  7051.            (if (const-p b)
  7052.              (make-anode
  7053.                :type 'FUNCTION
  7054.                :sub-anodes '()
  7055.                :seclass '(NIL . NIL)
  7056.                :code `((FCONST ,(const-value b)))
  7057.              )
  7058.              (c-VAR (var-name b))
  7059.           ))
  7060.           (t (compiler-error 'c-FUNCTION))
  7061.       ) )
  7062.       (let ((funname (car (last *form*))))
  7063.         (if (and (consp funname) (eq (car funname) 'LAMBDA) (consp (cdr funname)))
  7064.           (let ((*no-code* (or *no-code* (null *for-value*))))
  7065.             (c-fnode-function
  7066.               (c-lambdabody
  7067.                 (if (and longp (function-name-p name))
  7068.                   name ; angegebener Funktionsname
  7069.                   (symbol-suffix (fnode-name *func*) (incf *anonymous-count*))
  7070.                 )
  7071.                 (cdr funname)
  7072.           ) ) )
  7073.           (c-error (DEUTSCH "Nur Symbole und Lambda-Ausdrⁿcke sind Namen von Funktionen, nicht ~S"
  7074.                     ENGLISH "Only symbols and lambda expressions are function names, not ~S"
  7075.                     FRANCAIS "Seuls les symboles et les expressions lambda sont des noms de fonction et non ~S")
  7076.                    funname
  7077. ) ) ) ) ) )
  7078.  
  7079. ; compiliere (%GENERIC-FUNCTION-LAMBDA . lambdabody)
  7080. (defun c-%GENERIC-FUNCTION-LAMBDA ()
  7081.   (test-list *form* 1)
  7082.   (let ((*no-code* (or *no-code* (null *for-value*))))
  7083.     (c-fnode-function
  7084.       (c-lambdabody
  7085.         (symbol-suffix (fnode-name *func*) (incf *anonymous-count*))
  7086.         (cdr *form*)
  7087.         nil
  7088.         t ; gf-p = T, Code fⁿr generische Funktion bauen
  7089. ) ) ) )
  7090.  
  7091. ; compiliere (%OPTIMIZE-FUNCTION-LAMBDA reqoptimflags . lambdabody)
  7092. ; reqoptimflags ist eine Liste von Flags, welche Required-Parameter des
  7093. ; lambdabody wegoptimiert werden dⁿrfen. Zu jedem Required-Parameter:
  7094. ; NIL: normal,
  7095. ; T: darf wegoptimiert werden, dann wird daraus GONE gemacht.
  7096. ; NILs am Schlu▀ der Liste dⁿrfen weggelassen werden.
  7097. ; Die Ausgabe enthΣlt zusΣtzlich zur Funktion die Liste der Wegoptimierten.
  7098. (defmacro %OPTIMIZE-FUNCTION-LAMBDA (reqoptimflags &rest lambdabody)
  7099.   (declare (ignore reqoptimflags))
  7100.   `(CONS (FUNCTION (LAMBDA ,@lambdabody)) NIL) ; ohne Compiler: nicht optimieren
  7101. )
  7102. (defun c-%OPTIMIZE-FUNCTION-LAMBDA ()
  7103.   (test-list *form* 2)
  7104.   (let ((*no-code* (or *no-code* (null *for-value*))))
  7105.     (let* ((reqoptimflags (copy-list (second *form*)))
  7106.            (anode1
  7107.              (c-fnode-function
  7108.                (c-lambdabody
  7109.                  (symbol-suffix (fnode-name *func*) (incf *anonymous-count*))
  7110.                  (cddr *form*)
  7111.                  nil nil reqoptimflags
  7112.            ) ) )
  7113.            (resultflags (mapcar #'(lambda (x) (eq x 'GONE)) reqoptimflags))
  7114.            (anode2 (let ((*stackz* (cons 1 *stackz*))
  7115.                          (*form* `(QUOTE ,resultflags)))
  7116.                      (c-QUOTE)
  7117.           ))       )
  7118.       (make-anode :type '%OPTIMIZE-FUNCTION-LAMBDA
  7119.                   :sub-anodes (list anode1 anode2)
  7120.                   :seclass (anodes-seclass-or anode1 anode2)
  7121.                   :code `(,anode1 (PUSH) ,anode2 (CONS))
  7122. ) ) ) )
  7123.  
  7124. (macrolet ((err-syntax (specform fdef)
  7125.              `(catch 'c-error
  7126.                 (c-error (DEUTSCH "Falsche Syntax einer Funktionsdefinition in ~S: ~S"
  7127.                           ENGLISH "Illegal function definition syntax in ~S: ~S"
  7128.                           FRANCAIS "Mauvaise syntaxe de dΘfinition de fonction dans ~S : ~S")
  7129.                          ,specform ,fdef
  7130.               ) )
  7131.           ))
  7132.  
  7133. ; compiliere (FLET ({fundef}*) {form}*)
  7134. (defun c-FLET ()
  7135.   (test-list *form* 2)
  7136.   (test-list (second *form*) 0)
  7137.   (multiple-value-bind (namelist fnodelist)
  7138.       (do ((fdefsr (second *form*) (cdr fdefsr))
  7139.            (L1 '())
  7140.            (L2 '()))
  7141.           ((null fdefsr) (values (nreverse L1) (nreverse L2)))
  7142.         (let ((fdef (car fdefsr)))
  7143.           (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7144.             (let ((fnode (c-lambdabody
  7145.                            (symbol-suffix (fnode-name *func*) (car fdef))
  7146.                            (cdr fdef)
  7147.                  ))      )
  7148.               (push (car fdef) L1)
  7149.               (push fnode L2)
  7150.             )
  7151.             (err-syntax 'FLET fdef)
  7152.       ) ) )
  7153.     ; namelist = Liste der Namen, fnodelist = Liste der fnodes der Funktionen
  7154.     (let ((oldstackz *stackz*)
  7155.           (*stackz* *stackz*)
  7156.           (*venvc* *venvc*)
  7157.           (*venv* *venv*))
  7158.       (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  7159.       (let ((closuredummy-stackz *stackz*)
  7160.             (closuredummy-venvc *venvc*))
  7161.         (multiple-value-bind (varlist anodelist *fenv*)
  7162.             (do ((namelistr namelist (cdr namelistr))
  7163.                  (fnodelistr fnodelist (cdr fnodelistr))
  7164.                  (varlist '())
  7165.                  (anodelist '())
  7166.                  (fenv '()))
  7167.                 ((null namelistr)
  7168.                  (values (nreverse varlist) (nreverse anodelist)
  7169.                          (apply #'vector (nreverse (cons *fenv* fenv)))
  7170.                 ))
  7171.               (push (car namelistr) fenv)
  7172.               (let ((fnode (car fnodelistr)))
  7173.                 (if (zerop (fnode-keyword-offset fnode))
  7174.                   ; Funktionsdefinition ist autonom
  7175.                   (push (cons (list fnode) (make-const :horizont ':value :value fnode)) fenv)
  7176.                   (progn
  7177.                     (push (c-fnode-function fnode) anodelist)
  7178.                     (push 1 *stackz*)
  7179.                     (let ((var (make-var :name (gensym) :specialp nil
  7180.                                  :constantp nil :usedp t :really-usedp nil
  7181.                                  :closurep nil ; spΣter evtl. auf T gesetzt
  7182.                                  :stackz *stackz* :venvc *venvc*
  7183.                          ))    )
  7184.                       (push (cons (list fnode) var) fenv)
  7185.                       (push var varlist)
  7186.             ) ) ) ) )
  7187.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7188.           (let* ((body-anode ; restliche Formen compilieren
  7189.                    (c-form `(PROGN ,@(cddr *form*)))
  7190.                  )
  7191.                  (closurevars (checking-movable-var-list varlist anodelist))
  7192.                  (anode
  7193.                    (make-anode
  7194.                      :type 'FLET
  7195.                      :sub-anodes `(,@anodelist ,body-anode)
  7196.                      :seclass (seclass-without
  7197.                                 (anodelist-seclass-or `(,@anodelist ,body-anode))
  7198.                                 varlist
  7199.                               )
  7200.                      :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7201.                              ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7202.                              ,body-anode
  7203.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7204.                    )        )
  7205.                 ))
  7206.             (when closurevars
  7207.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  7208.               (setf (first closuredummy-venvc)
  7209.                 (cons closurevars closuredummy-stackz)
  7210.             ) )
  7211.             (optimize-var-list varlist)
  7212.             anode
  7213. ) ) ) ) ) )
  7214.  
  7215. ; compiliere (LABELS ({fundef}*) {form}*)
  7216. (defun c-LABELS ()
  7217.   (test-list *form* 2)
  7218.   (test-list (second *form*) 0)
  7219.   (let ((oldstackz *stackz*)
  7220.         (*stackz* *stackz*)
  7221.         (*venvc* *venvc*)
  7222.         (*venv* *venv*))
  7223.     (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  7224.     (let ((closuredummy-stackz *stackz*)
  7225.           (closuredummy-venvc *venvc*))
  7226.       (multiple-value-bind (namelist varlist lambdanamelist lambdabodylist fenvconslist)
  7227.           (do ((fdefsr (second *form*) (cdr fdefsr))
  7228.                (L1 '())
  7229.                (L2 '())
  7230.                (L3 '())
  7231.                (L4 '())
  7232.                (L5 '()))
  7233.               ((null fdefsr)
  7234.                (values (nreverse L1) (nreverse L2) (nreverse L3) (nreverse L4) (nreverse L5))
  7235.               )
  7236.             (let ((fdef (car fdefsr)))
  7237.               (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7238.                 (progn
  7239.                   (push (car fdef) L1)
  7240.                   (push 1 *stackz*)
  7241.                   (push (make-var :name (gensym) :specialp nil
  7242.                                   :constantp nil :usedp t :really-usedp nil
  7243.                                   :closurep nil ; spΣter evtl. auf T gesetzt
  7244.                                   :stackz *stackz* :venvc *venvc*
  7245.                         )
  7246.                         L2
  7247.                   )
  7248.                   (push (symbol-suffix (fnode-name *func*) (car fdef)) L3)
  7249.                   (push (cdr fdef) L4)
  7250.                   (push
  7251.                     (cons
  7252.                       ; fdescr, bestehend aus:
  7253.                       (cons nil ; Platz fⁿr den FNODE
  7254.                         (cons 'LABELS
  7255.                           (multiple-value-list ; Werten von analyze-lambdalist
  7256.                             (analyze-lambdalist (cadr fdef))
  7257.                       ) ) )
  7258.                       ; Variable
  7259.                       (car L2)
  7260.                     )
  7261.                     L5
  7262.                 ) )
  7263.                 (err-syntax 'LABELS fdef)
  7264.           ) ) )
  7265.         ; namelist = Liste der Namen, varlist = Liste der Variablen,
  7266.         ; lambdanamelist = Liste der Dummynamen der Funktionen,
  7267.         ; lambdabodylist = Liste der Lambdabodys der Funktionen,
  7268.         ; fenvconslist = Liste der Conses (fdescr . var) fⁿr *fenv*
  7269.         ; (jeweils fdescr noch ohne den fnode, der kommt erst spΣter hinein).
  7270.         (let ((*fenv* ; Funktionsnamen aktivieren
  7271.                 (do ((namelistr namelist (cdr namelistr))
  7272.                      (fenvconslistr fenvconslist (cdr fenvconslistr))
  7273.                      (L nil))
  7274.                     ((null namelistr)
  7275.                      (push *fenv* L)
  7276.                      (apply #'vector (nreverse L))
  7277.                     )
  7278.                   (push (car namelistr) L)
  7279.                   (push (car fenvconslistr) L)
  7280.              )) )
  7281.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7282.           (let* ((fnodelist ; Funktionen compilieren
  7283.                    (mapcar #'c-lambdabody lambdanamelist lambdabodylist fenvconslist)
  7284.                  )
  7285.                  (anodelist
  7286.                    (mapcar #'(lambda (fnode var)
  7287.                                (c-fnode-function fnode (cdr (var-stackz var)))
  7288.                              )
  7289.                            fnodelist varlist
  7290.                  ) )
  7291.                  (body-anode ; restliche Formen compilieren
  7292.                    (c-form `(PROGN ,@(cddr *form*)))
  7293.                 ))
  7294.             ; die Variablen, zu denen die Funktion autonom war, werden nach-
  7295.             ; trΣglich zu Konstanten erklΣrt:
  7296.             (do ((varlistr varlist (cdr varlistr))
  7297.                  (fnodelistr fnodelist (cdr fnodelistr)))
  7298.                 ((null varlistr))
  7299.               (let ((var (car varlistr))
  7300.                     (fnode (car fnodelistr)))
  7301.                 (when (zerop (fnode-keyword-offset fnode))
  7302.                   ; Funktionsdefinition ist autonom
  7303.                   (setf (var-constantp var) t)
  7304.                   (setf (var-constant var) (new-const fnode))
  7305.             ) ) )
  7306.             (let* ((closurevars (checking-movable-var-list varlist anodelist))
  7307.                    (anode
  7308.                      (make-anode
  7309.                        :type 'LABELS
  7310.                        :sub-anodes `(,@anodelist ,body-anode)
  7311.                        :seclass (seclass-without
  7312.                                   (anodelist-seclass-or `(,@anodelist ,body-anode))
  7313.                                   varlist
  7314.                                 )
  7315.                        :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7316.                                ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7317.                                ,body-anode
  7318.                                (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7319.                      )        )
  7320.                   ))
  7321.               (when closurevars
  7322.                 (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  7323.                 (setf (first closuredummy-venvc)
  7324.                   (cons closurevars closuredummy-stackz)
  7325.               ) )
  7326.               (optimize-var-list varlist)
  7327.               anode
  7328. ) ) ) ) ) ) )
  7329.  
  7330. ; compiliere (CLOS:GENERIC-FLET ({genfundefs}*) {form}*)
  7331. (defun c-GENERIC-FLET ()
  7332.   (test-list *form* 2)
  7333.   (test-list (second *form*) 0)
  7334.   (multiple-value-bind (namelist signlist formlist)
  7335.       (do ((fdefsr (second *form*) (cdr fdefsr))
  7336.            (L1 '())
  7337.            (L2 '())
  7338.            (L3 '()))
  7339.           ((null fdefsr) (values (nreverse L1) (nreverse L2) (nreverse L3)))
  7340.         (let ((fdef (car fdefsr)))
  7341.           (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7342.             (let ((name (first fdef)))
  7343.               (push name L1)
  7344.               (push (clos::defgeneric-lambdalist-callinfo 'clos:generic-flet name (second fdef))
  7345.                     L2
  7346.               )
  7347.               (push (clos::make-generic-function-form 'clos:generic-flet
  7348.                       name (second fdef) (cddr fdef) (vector *venv* *fenv*)
  7349.                     )
  7350.                     L3
  7351.             ) )
  7352.             (err-syntax 'CLOS:GENERIC-FLET fdef)
  7353.       ) ) )
  7354.     ; namelist = Liste der Namen,
  7355.     ; signlist = Liste der Signaturen der generischen Funktionen,
  7356.     ; formlist = Liste der Konstruktor-Formen der generischen Funktionen.
  7357.     (let ((oldstackz *stackz*)
  7358.           (*stackz* *stackz*)
  7359.           (*venvc* *venvc*)
  7360.           (*venv* *venv*))
  7361.       (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  7362.       (let ((closuredummy-stackz *stackz*)
  7363.             (closuredummy-venvc *venvc*))
  7364.         (multiple-value-bind (varlist anodelist *fenv*)
  7365.             (do ((namelistr namelist (cdr namelistr))
  7366.                  (signlistr signlist (cdr signlistr))
  7367.                  (formlistr formlist (cdr formlistr))
  7368.                  (varlist '())
  7369.                  (anodelist '())
  7370.                  (fenv '()))
  7371.                 ((null namelistr)
  7372.                  (values (nreverse varlist) (nreverse anodelist)
  7373.                          (apply #'vector (nreverse (cons *fenv* fenv)))
  7374.                 ))
  7375.               (push (car namelistr) fenv)
  7376.               (push (c-form (car formlistr) 'ONE) anodelist)
  7377.               (push 1 *stackz*)
  7378.               (let ((var (make-var :name (gensym) :specialp nil
  7379.                            :constantp nil :usedp t :really-usedp nil
  7380.                            :closurep nil ; spΣter evtl. auf T gesetzt
  7381.                            :stackz *stackz* :venvc *venvc*
  7382.                    ))    )
  7383.                 (push (cons (list* nil 'GENERIC (car signlistr)) var) fenv)
  7384.                 (push var varlist)
  7385.             ) )
  7386.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7387.           (let* ((body-anode ; restliche Formen compilieren
  7388.                    (c-form `(PROGN ,@(cddr *form*)))
  7389.                  )
  7390.                  (closurevars (checking-movable-var-list varlist anodelist))
  7391.                  (anode
  7392.                    (make-anode
  7393.                      :type 'CLOS:GENERIC-FLET
  7394.                      :sub-anodes `(,@anodelist ,body-anode)
  7395.                      :seclass (seclass-without
  7396.                                 (anodelist-seclass-or `(,@anodelist ,body-anode))
  7397.                                 varlist
  7398.                               )
  7399.                      :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7400.                              ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7401.                              ,body-anode
  7402.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7403.                    )        )
  7404.                 ))
  7405.             (when closurevars
  7406.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  7407.               (setf (first closuredummy-venvc)
  7408.                 (cons closurevars closuredummy-stackz)
  7409.             ) )
  7410.             (optimize-var-list varlist)
  7411.             anode
  7412. ) ) ) ) ) )
  7413.  
  7414. ; compiliere (CLOS:GENERIC-LABELS ({genfundefs}*) {form}*)
  7415. (defun c-GENERIC-LABELS ()
  7416.   (test-list *form* 2)
  7417.   (test-list (second *form*) 0)
  7418.   (let ((oldstackz *stackz*)
  7419.         (*stackz* *stackz*)
  7420.         (*venvc* *venvc*)
  7421.         (*venv* *venv*))
  7422.     (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  7423.     (let ((closuredummy-stackz *stackz*)
  7424.           (closuredummy-venvc *venvc*))
  7425.       (multiple-value-bind (namelist varlist fenvconslist formlist)
  7426.           (do ((fdefsr (second *form*) (cdr fdefsr))
  7427.                (L1 '())
  7428.                (L2 '())
  7429.                (L3 '())
  7430.                (L4 '()))
  7431.               ((null fdefsr)
  7432.                (values (nreverse L1) (nreverse L2) (nreverse L3) (nreverse L4))
  7433.               )
  7434.             (let ((fdef (car fdefsr)))
  7435.               (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7436.                 (let ((name (first fdef)))
  7437.                   (push name L1)
  7438.                   (push 1 *stackz*)
  7439.                   (push (make-var :name (gensym) :specialp nil
  7440.                                   :constantp nil :usedp t :really-usedp nil
  7441.                                   :closurep nil ; spΣter evtl. auf T gesetzt
  7442.                                   :stackz *stackz* :venvc *venvc*
  7443.                         )
  7444.                         L2
  7445.                   )
  7446.                   (push (cons
  7447.                           ; fdescr
  7448.                           (list* nil 'GENERIC
  7449.                                  (clos::defgeneric-lambdalist-callinfo 'clos:generic-labels name (second fdef))
  7450.                           )
  7451.                           ; Variable
  7452.                           (car L2)
  7453.                         )
  7454.                         L3
  7455.                   )
  7456.                   (push (clos::make-generic-function-form 'clos:generic-labels
  7457.                           name (second fdef) (cddr fdef) (vector *venv* *fenv*)
  7458.                         )
  7459.                         L4
  7460.                 ) )
  7461.                 (err-syntax 'CLOS:GENERIC-LABELS fdef)
  7462.           ) ) )
  7463.         ; namelist = Liste der Namen, varlist = Liste der Variablen,
  7464.         ; fenvconslist = Liste der Conses (fdescr . var) fⁿr *fenv*,
  7465.         ; formlist = Liste der Konstruktor-Formen der generischen Funktionen.
  7466.         (let ((*fenv* ; Funktionsnamen aktivieren
  7467.                 (do ((namelistr namelist (cdr namelistr))
  7468.                      (fenvconslistr fenvconslist (cdr fenvconslistr))
  7469.                      (L nil))
  7470.                     ((null namelistr)
  7471.                      (push *fenv* L)
  7472.                      (apply #'vector (nreverse L))
  7473.                     )
  7474.                   (push (car namelistr) L)
  7475.                   (push (car fenvconslistr) L)
  7476.              )) )
  7477.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7478.           (let* ((anodelist
  7479.                    (mapcar #'(lambda (form) (c-form form 'ONE)) formlist)
  7480.                  )
  7481.                  (body-anode ; restliche Formen compilieren
  7482.                    (c-form `(PROGN ,@(cddr *form*)))
  7483.                  )
  7484.                  (closurevars (checking-movable-var-list varlist anodelist))
  7485.                  (anode
  7486.                    (make-anode
  7487.                      :type 'CLOS:GENERIC-LABELS
  7488.                      :sub-anodes `(,@anodelist ,body-anode)
  7489.                      :seclass (seclass-without
  7490.                                 (anodelist-seclass-or `(,@anodelist ,body-anode))
  7491.                                 varlist
  7492.                               )
  7493.                      :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7494.                              ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7495.                              ,body-anode
  7496.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7497.                    )        )
  7498.                 ))
  7499.             (when closurevars
  7500.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  7501.               (setf (first closuredummy-venvc)
  7502.                 (cons closurevars closuredummy-stackz)
  7503.             ) )
  7504.             (optimize-var-list varlist)
  7505.             anode
  7506. ) ) ) ) ) )
  7507.  
  7508. ) ; macrolet
  7509.  
  7510. ; compiliere (MACROLET ({macrodef}*) {form}*)
  7511. (defun c-MACROLET (&optional (c #'c-form))
  7512.   (test-list *form* 2)
  7513.   (test-list (second *form*) 0)
  7514.   (do ((L1 (second *form*) (cdr L1))
  7515.        (L2 '()))
  7516.       ((null L1)
  7517.        (push *fenv* L2)
  7518.        (let ((*fenv* (apply #'vector (nreverse L2)))) ; *fenv* erweitern
  7519.          (funcall c `(PROGN ,@(cddr *form*))) ; restliche Formen compilieren
  7520.       ))
  7521.     (let* ((macrodef (car L1))
  7522.            (name (car macrodef)))
  7523.       (push name L2)
  7524.       (push #+CLISP (sys::make-macro-expandercons macrodef)
  7525.             #-CLISP (cons 'SYSTEM::MACRO (make-macro-expander macrodef))
  7526.             L2
  7527.   ) ) )
  7528. )
  7529.  
  7530. ; compiliere (SYMBOL-MACROLET ({symdef}*) {declaration}* {form}*)
  7531. (defun c-SYMBOL-MACROLET (&optional (c #'c-form))
  7532.   (test-list *form* 2)
  7533.   (test-list (second *form*) 0)
  7534.   (multiple-value-bind (body-rest declarations)
  7535.       (parse-body (cddr *form*) nil (vector *venv* *fenv*))
  7536.     (let ((*denv* *denv*)
  7537.           (*venv* *venv*))
  7538.       (multiple-value-bind (*specials* *ignores* *ignorables*)
  7539.           (process-declarations declarations)
  7540.         ; Special-Variable auf *venv* pushen:
  7541.         (push-specials)
  7542.         ; Syntaxtest der Parameterliste:
  7543.         (multiple-value-bind (symbols expansions)
  7544.             (do ((L (second *form*) (cdr L))
  7545.                  (symbols nil)
  7546.                  (expansions nil))
  7547.                 ((null L) (values (nreverse symbols) (nreverse expansions)))
  7548.               (let ((symdef (car L)))
  7549.                 (if (and (consp symdef) (symbolp (car symdef))
  7550.                          (consp (cdr symdef)) (null (cddr symdef))
  7551.                     )
  7552.                   (progn (push (first symdef) symbols) (push (second symdef) expansions))
  7553.                   (catch 'c-error
  7554.                     (c-error (DEUTSCH "Falsche Syntax in SYMBOL-MACROLET: ~S"
  7555.                               ENGLISH "Illegal syntax in SYMBOL-MACROLET: ~S"
  7556.                               FRANCAIS "Mauvaise syntaxe pour SYMBOL-MACROLET : ~S")
  7557.                              symdef
  7558.             ) ) ) ) )
  7559.           (dolist (s (intersection *specials* symbols))
  7560.             (catch 'c-error
  7561.               (c-error (DEUTSCH "~S: Symbol ~S darf nicht gleichzeitig SPECIAL und Makro deklariert werden."
  7562.                         ENGLISH "~S: symbol ~S must not be declared SPECIAL and a macro at the same time"
  7563.                         FRANCAIS "~S : Le symbole ~S ne peut Ωtre dΘclarΘ SPECIAL et macro en mΩme temps.")
  7564.                        'symbol-macrolet s
  7565.           ) ) )
  7566.           (setq *venv* ; *venv* erweitern
  7567.             (apply #'vector
  7568.               (nconc (mapcan #'(lambda (sym expansion) (list sym (make-symbol-macro expansion)))
  7569.                              symbols expansions
  7570.                      )
  7571.                      (list *venv*)
  7572.           ) ) )
  7573.           (funcall c `(PROGN ,@body-rest)) ; restliche Formen compilieren
  7574. ) ) ) ) )
  7575.  
  7576. ; compiliere (EVAL-WHEN ({situation}*) {form}*)
  7577. (defun c-EVAL-WHEN (&optional (c #'c-form))
  7578.   (test-list *form* 2)
  7579.   (test-list (second *form*) 0)
  7580.   (let ((load-flag nil)
  7581.         (compile-flag nil)
  7582.         (compile-once-only nil))
  7583.     (dolist (situation (second *form*))
  7584.       (case situation
  7585.         (LOAD (setq load-flag t))
  7586.         (COMPILE (setq compile-flag t))
  7587.         (EVAL)
  7588.         (COMPILE-ONCE-ONLY (setq compile-once-only t))
  7589.         (T (cond ((equal situation '(NOT EVAL)) (setq load-flag t compile-flag t))
  7590.                  ((equal situation '(NOT COMPILE)) (setq load-flag t))
  7591.                  (t (c-error (DEUTSCH "Situation bei EVAL-WHEN mu▀ EVAL, LOAD oder COMPILE sein, nicht ~S."
  7592.                               ENGLISH "EVAL-WHEN situation must be EVAL or LOAD or COMPILE, but not ~S"
  7593.                               FRANCAIS "EVAL-WHEN ne s'applique qu'aux situations EVAL, LOAD ou COMPILE et non ~S.")
  7594.                              situation
  7595.     ) ) )  )     )  )
  7596.     (let ((form `(PROGN ,@(cddr *form*))))
  7597.       (if compile-flag
  7598.         (c-eval-when-compile form) ; ausfⁿhren und ins Lib-File schreiben
  7599.         (if compile-once-only
  7600.           (eval form) ; nur jetzt ausfⁿhren, nicht ins Lib-File schreiben
  7601.       ) )
  7602.       (funcall c (if load-flag form 'NIL))
  7603. ) ) )
  7604.  
  7605. ; compiliere (COND {clause}*)
  7606. (defun c-COND ()
  7607.   (test-list *form* 1)
  7608.   (c-form
  7609.     (let ((clauses (cdr *form*))) ; (COND . clauses) macroexpandieren
  7610.       (if (null clauses)
  7611.         'NIL
  7612.         (let ((clause (car clauses)))
  7613.           (if (atom clause)
  7614.             (c-error (DEUTSCH "COND-Klausel ohne Test: ~S"
  7615.                       ENGLISH "COND clause without test: ~S"
  7616.                       FRANCAIS "Clause COND sans test : ~S")
  7617.                      clause
  7618.             )
  7619.             (let ((test (car clause)))
  7620.               (if (cdr clause)
  7621.                 `(IF ,test (PROGN ,@(cdr clause)) (COND ,@(cdr clauses)))
  7622.                 `(OR ,test (COND ,@(cdr clauses)))
  7623. ) ) ) ) ) ) ) )
  7624.  
  7625.  
  7626. ;               ERSTER PASS :   M A C R O S
  7627.  
  7628. ; compiliere (CASE keyform {clause}*)
  7629. (defun c-CASE ()
  7630.   (test-list *form* 1)
  7631.   (let ((keyform (second *form*))
  7632.         (clauses (cddr *form*))
  7633.         ; clauses vereinfachen:
  7634.         (newclauses '())
  7635.         (allkeys '()))
  7636.     (let ((default-passed nil))
  7637.       (do ((clauses clauses))
  7638.           ((endp clauses))
  7639.         (let ((clause (pop clauses)))
  7640.           (if (atom clause)
  7641.             (c-error (DEUTSCH "CASE-Klausel ohne Objekte: ~S"
  7642.                       ENGLISH "CASE clause without objects: ~S"
  7643.                       FRANCAIS "Clause CASE sans objets LISP : ~S")
  7644.                      clause
  7645.             )
  7646.             (let ((keys (car clause)))
  7647.               (if default-passed ; war der Default schon da?
  7648.                 (setq keys nil)
  7649.                 (if (or (eq keys 'T) (eq keys 'OTHERWISE))
  7650.                   (progn
  7651.                     (when clauses
  7652.                       (catch 'c-error
  7653.                         (c-error (DEUTSCH "~S: Die ~S-Klausel mu▀ die letzte sein: ~S"
  7654.                                   ENGLISH "~S: the ~S clause must be the last one: ~S"
  7655.                                   FRANCAIS "~S : La clause ~S doit Ωtre la derniΦre: ~S")
  7656.                                  'case keys *form*
  7657.                     ) ) )
  7658.                     (setq keys 'T)
  7659.                     (setq default-passed t)
  7660.                   )
  7661.                   (let ((newkeys '()))
  7662.                     (dolist (key (if (listp keys) keys (list keys)))
  7663.                       (if (not (member key allkeys :test #'eql)) ; remove-duplicates
  7664.                         (progn (push key allkeys) (push key newkeys))
  7665.                         (c-warn (DEUTSCH "Doppelt aufgefⁿhrter ~S-Fall ~S : ~S"
  7666.                                  ENGLISH "Duplicate ~S label ~S : ~S"
  7667.                                  FRANCAIS "~S : Le choix ~S se rΘpΦte: ~S")
  7668.                                 'case key *form*
  7669.                     ) ) )
  7670.                     (setq keys (nreverse newkeys))
  7671.               ) ) )
  7672.               (push (cons keys (cdr clause)) newclauses)
  7673.       ) ) ) )
  7674.       (unless default-passed (push '(T NIL) newclauses))
  7675.       (setq newclauses (nreverse newclauses))
  7676.       (setq allkeys (nreverse allkeys))
  7677.     )
  7678.     ; newclauses enthΣlt jetzt keine doppelten keys, genau einmal T als keys,
  7679.     ; und allkeys ist die Menge aller Keys.
  7680.     (if (<= (length allkeys) 2) ; wenige Keys -> direkt EQL verwenden
  7681.       (let ((keyvar (gensym)))
  7682.         (labels ((ifify (clauses)
  7683.                    (if (null clauses)
  7684.                      'NIL
  7685.                      `(IF ,(let ((keys (caar clauses)))
  7686.                              (if (listp keys)
  7687.                                `(OR ,@(mapcar
  7688.                                         #'(lambda (key) `(EQL ,keyvar ',key))
  7689.                                         keys
  7690.                                 )     )
  7691.                                'T ; keys = T, der Default-Fall
  7692.                            ) )
  7693.                         (PROGN ,@(cdar clauses))
  7694.                         ,(ifify (cdr clauses))
  7695.                       )
  7696.                 )) )
  7697.           (c-form
  7698.             `(LET ((,keyvar ,keyform)) (PROGN ,keyvar ,(ifify newclauses)))
  7699.       ) ) )
  7700.       (let ((keyform-anode (c-form keyform 'ONE))
  7701.             (default-anode nil)
  7702.             (cases '())) ; Liste von Tripeln (keylist label anode)
  7703.         (dolist (clause newclauses)
  7704.           (if (car clause)
  7705.             (let ((anode (c-form `(PROGN ,@(cdr clause)))))
  7706.               (if (atom (car clause))
  7707.                 (setq default-anode anode)
  7708.                 (push (list (car clause) (make-label 'NIL) anode) cases)
  7709.             ) )
  7710.             (let ((*no-code* t)) (c-form `(PROGN ,@(cdr clause)) 'NIL))
  7711.         ) )
  7712.         (setq cases (nreverse cases))
  7713.         (if (anode-constantp keyform-anode)
  7714.           (let ((value (anode-constant-value keyform-anode)))
  7715.             (dolist (case cases default-anode)
  7716.               (when (member value (first case) :test #'eql)
  7717.                 (return (third case))
  7718.           ) ) )
  7719.           (let ((default-label (make-label 'NIL))
  7720.                 (end-label (make-label *for-value*))
  7721.                 (test (if (every #'EQL=EQ allkeys) 'EQ 'EQL)))
  7722.             (make-anode
  7723.               :type 'CASE
  7724.               :sub-anodes `(,keyform-anode ,@(mapcar #'third cases) ,default-anode)
  7725.               :seclass
  7726.                 (anodelist-seclass-or
  7727.                   `(,keyform-anode ,@(mapcar #'third cases) ,default-anode)
  7728.                 )
  7729.               :code
  7730.                 `(,keyform-anode
  7731.                   (JMPHASH
  7732.                     ,test
  7733.                     ,(mapcap ; Aliste (obji -> labeli)
  7734.                        #'(lambda (case)
  7735.                            (let ((label (second case)))
  7736.                              (mapcar #'(lambda (obj) (cons obj label))
  7737.                                      (first case)
  7738.                          ) ) )
  7739.                        cases
  7740.                      )
  7741.                     ,default-label
  7742.                     ,@(mapcar #'second cases) ; alle Labels, ohne Doppelte
  7743.                   )
  7744.                   ,@(mapcap
  7745.                       #'(lambda (case)
  7746.                           `(,(second case) ; Label
  7747.                             ,(third case) ; Anode
  7748.                             (JMP ,end-label)
  7749.                            )
  7750.                         )
  7751.                       cases
  7752.                     )
  7753.                   ,default-label
  7754.                   ,default-anode
  7755.                   ,end-label
  7756.                  )
  7757.           ) )
  7758. ) ) ) ) )
  7759.  
  7760. ; compiliere (HANDLER-BIND ({(typespec handler)}*) {form}*)
  7761. ; und  (SYS::%HANDLER-BIND ({(typespec handler)}*) {form}*)
  7762. (defun c-HANDLER-BIND ()
  7763.   (test-list *form* 2)
  7764.   (test-list (second *form*) 0)
  7765.   (let ((body (cddr *form*))
  7766.         (types '())
  7767.         (handler-labels '())
  7768.         (handler-anodes '()))
  7769.     (dolist (clause (second *form*))
  7770.       (test-list clause 2 2)
  7771.       (let ((type (first clause))
  7772.             (handler (second clause)))
  7773.         (if (block try-subtypep
  7774.               (let ((*error-handler*
  7775.                       #'(lambda (&rest error-args)
  7776.                           (declare (ignore error-args))
  7777.                           (return-from try-subtypep nil)
  7778.                    ))   )
  7779.                 (subtypep type `(OR ,@types))
  7780.             ) )
  7781.           ; Brauche diesen Handler nicht zu berⁿcksichtigen
  7782.           (let ((*no-code* t) (*for-value* 'NIL)) (c-form handler))
  7783.           ; Der Handler ist eine Funktion mit dynamischem Extent.
  7784.           (let ((label (make-label 'ONE)))
  7785.             (push type types)
  7786.             (push label handler-labels)
  7787.             (push
  7788.               (let* ((*stackz* (cons 'ANYTHING *stackz*))
  7789.                      (oldstackz *stackz*)
  7790.                      (*venv* *venv*))
  7791.                 ; Platz fⁿr die Funktion selbst:
  7792.                 (push 1 *stackz*)
  7793.                 (let* ((condition-sym (gensym))
  7794.                        (condition-anode
  7795.                          (make-anode :type 'CONDITION
  7796.                                      :sub-anodes '()
  7797.                                      :seclass '(T . NIL)
  7798.                                      :code '() ; vorher kommt (HANDLER-BEGIN)
  7799.                        ) )
  7800.                        (condition-var (bind-movable-var condition-sym condition-anode)))
  7801.                   (push-*venv* condition-var)
  7802.                   (let ((body-anode
  7803.                           (c-form `(SYS::%FUNCALL ,handler ,condition-sym) 'NIL)
  7804.                        ))
  7805.                     ; ▄berprⁿfen der Variablen (mu▀ nicht in die Closure):
  7806.                     (checking-movable-var-list (list condition-var) (list condition-anode))
  7807.                     (let* ((codelist
  7808.                              `(,label
  7809.                                (HANDLER-BEGIN)
  7810.                                ,@(c-bind-movable-var-anode condition-var condition-anode)
  7811.                                ,body-anode
  7812.                                (UNWINDSP ,*stackz* ,*func*) ; ein (SKIPSP k1 k2)
  7813.                                (UNWIND ,*stackz* ,oldstackz NIL) ; ein (SKIP 2)
  7814.                                (RET)
  7815.                               )
  7816.                            )
  7817.                            (anode
  7818.                              (make-anode
  7819.                                :type 'HANDLER
  7820.                                :sub-anodes `(,body-anode)
  7821.                                :seclass '(T . T) ; eigentlich irrelevant
  7822.                                :stackz oldstackz
  7823.                                :code codelist
  7824.                           )) )
  7825.                       (optimize-var-list (list condition-var))
  7826.                       anode
  7827.               ) ) ) )
  7828.               handler-anodes
  7829.             )
  7830.     ) ) ) )
  7831.     (if (null types)
  7832.       (c-form `(PROGN ,@body))
  7833.       (progn
  7834.         (setq types (nreverse types))
  7835.         (setq handler-labels (nreverse handler-labels))
  7836.         (setq handler-anodes (nreverse handler-anodes))
  7837.         (let* ((label (make-label 'NIL))
  7838.                (oldstackz *stackz*)
  7839.                (*stackz* (cons 4 *stackz*)) ; HANDLER-Frame
  7840.                (body-anode (c-form `(PROGN ,@body))))
  7841.           (make-anode
  7842.             :type 'HANDLER-BIND
  7843.             :sub-anodes `(,body-anode ,@handler-anodes)
  7844.             :seclass (anodelist-seclass-or `(,body-anode ,@handler-anodes))
  7845.             :stackz oldstackz
  7846.             :code `((HANDLER-OPEN ,(new-const (coerce types 'vector)) ,*stackz* ,@handler-labels)
  7847.                     (JMP ,label)
  7848.                     ,@handler-anodes
  7849.                     ,label
  7850.                     ,body-anode
  7851.                     (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7852.                    )
  7853.     ) ) ) )
  7854. ) )
  7855.  
  7856. ; compiliere (SYS::CONSTANT-EQL form1 form2 form3)
  7857. (defun c-CONSTANT-EQL ()
  7858.   (test-list *form* 4 4)
  7859.   (let ((form1 (second *form*))
  7860.         (form23 (cddr *form*)))
  7861.     (if (and *compiling-from-file*
  7862.              (c-constantp form1)
  7863.              (let ((value (c-constant-value form1)))
  7864.                (or (stringp value) (bit-vector-p value))
  7865.         )    )
  7866.       (c-form `(SYS::LOOSE-CONSTANT-EQL ,@form23))
  7867.       (c-form `(EQL ,@form23))
  7868. ) ) )
  7869.  
  7870.  
  7871. ;   ERSTER PASS :   I N L I N E - F U N K T I O N E N   (PRIMOPS)
  7872.  
  7873. ; Funktionsaufrufe, die wie special forms behandelt werden:
  7874.  
  7875. ; Erst FUNCALL bzw. SYS::%FUNCALL.
  7876.  
  7877. ; (c-FUNCALL-NOTINLINE funform args) compiliert einen Funktionsaufruf
  7878. ; (SYS::%FUNCALL funform . args),
  7879. ; fⁿr den das STACK-Layout der Argumente nicht zur Compile-Zeit bestimmt
  7880. ; werden kann.
  7881. (defun c-FUNCALL-NOTINLINE (funform args)
  7882.   (test-list args 0)
  7883.   (let* ((anode1 (c-form funform 'ONE))
  7884.          (*stackz* (cons 1 *stackz*)))
  7885.     (do ((formlistr args (cdr formlistr))
  7886.          #+COMPILER-DEBUG (anodelist (list anode1))
  7887.          (codelist (list '(FUNCALLP) anode1)))
  7888.         ((null formlistr)
  7889.          (push `(FUNCALL ,(length args)) codelist)
  7890.          (make-anode
  7891.            :type 'FUNCALL
  7892.            :sub-anodes (nreverse anodelist)
  7893.            :seclass '(T . T)
  7894.            :code (nreverse codelist)
  7895.         ))
  7896.       (let ((anode (c-form (car formlistr) 'ONE)))
  7897.         #+COMPILER-DEBUG (push anode anodelist)
  7898.         (push anode codelist)
  7899.       )
  7900.       (push '(PUSH) codelist)
  7901.       (push 1 *stackz*)
  7902. ) ) )
  7903.  
  7904. ; (c-FUNCALL-INLINE funform args applyargs lambdabody sameenv) compiliert einen
  7905. ; Funktionsaufruf (SYS::%FUNCALL funform . args) bzw.
  7906. ; (APPLY funform . args applyargs) [applyargs eine Liste aus einer Form],
  7907. ; fⁿr den das STACK-Layout der Argumente zur Compile-Zeit bestimmt werden kann.
  7908. ; sameenv gibt an, ob lambdabody im selben Environment oder im
  7909. ; Top-Level-Environment zu betrachten ist.
  7910. (defun c-FUNCALL-INLINE (funform arglist applyarglist lambdabody sameenv)
  7911.   (test-list lambdabody 1)
  7912.   (multiple-value-bind (reqvar  optvar optinit optsvar  restvar
  7913.                         keyflag keyword keyvar keyinit keysvar allow-other-keys
  7914.                         auxvar auxinit)
  7915.       (analyze-lambdalist (pop lambdabody))
  7916.     (when (or keyflag keyword keyvar keyinit keysvar allow-other-keys)
  7917.       (compiler-error 'c-FUNCALL-INLINE)
  7918.     )
  7919.     (let ((r (length reqvar)) ; Anzahl der required-Argumente
  7920.           (s (length optvar)) ; Anzahl der optionalen Argumente
  7921.           (|t| (length arglist))) ; Anzahl der angegebenen Argumente
  7922.       (when (and (null restvar) (> |t| (+ r s)))
  7923.         ; zu viele Argumente angegeben. Wird beseitigt durch Einfⁿhrung
  7924.         ; mehrerer zusΣtzlicher optionaler Argumente:
  7925.         (catch 'c-error
  7926.           (c-error (DEUTSCH "Zuviele Argumente fⁿr ~S"
  7927.                     ENGLISH "Too many arguments to ~S"
  7928.                     FRANCAIS "Trop d'arguments pour ~S")
  7929.                    funform
  7930.         ) )
  7931.         (dotimes (i (- |t| (+ r s)))
  7932.           (let ((var (gensym)))
  7933.             (setq optvar (append optvar (list var)))
  7934.             (setq optinit (append optinit (list nil)))
  7935.             (setq optsvar (append optsvar (list nil)))
  7936.             (incf s)
  7937.             (push `(DECLARE (IGNORE ,var)) lambdabody)
  7938.       ) ) )
  7939.       (when (and (null applyarglist) (< |t| r))
  7940.         ; zu wenige Argumente angegeben. Wird beseitigt durch Einfⁿhrung
  7941.         ; zusΣtzlicher Argumente:
  7942.         (catch 'c-error
  7943.           (c-error (DEUTSCH "Zuwenig Argumente fⁿr ~S"
  7944.                     ENGLISH "Too few arguments to ~S"
  7945.                     FRANCAIS "Trop peu d'arguments pour ~S")
  7946.                    funform
  7947.         ) )
  7948.         (setq arglist (append arglist (make-list (- r |t|) :initial-element nil)))
  7949.         (setq |t| r)
  7950.       )
  7951.       ; Nun ist (t>=r oder apply-arg da) und (t<=r+s oder &rest-Parameter da).
  7952.       (let ((oldstackz *stackz*)
  7953.             (oldvenv *venv*)
  7954.             (oldfenv *fenv*)
  7955.             (oldbenv *benv*)
  7956.             (oldgenv *genv*)
  7957.             (olddenv *denv*)
  7958.             (*stackz* *stackz*)
  7959.             (*venv* (and sameenv *venv*))
  7960.             (*venvc* *venvc*)
  7961.             (*fenv* (and sameenv *fenv*))
  7962.             (*benv* (and sameenv *benv*))
  7963.             (*genv* (and sameenv *genv*))
  7964.             (*denv* (if sameenv
  7965.                       *denv*
  7966.                       (cons `(INLINING ,funform)
  7967.                             (remove-if-not #'(lambda (declspec)
  7968.                                                (case (car declspec)
  7969.                                                  ((DECLARATION SYS::IN-DEFUN INLINING) t)
  7970.                                                  (t nil)
  7971.                                              ) )
  7972.                                            *denv*
  7973.            ))       ) )     )
  7974.         (multiple-value-bind (body-rest declarations)
  7975.             (parse-body lambdabody t (vector *venv* *fenv*))
  7976.           (let (*specials* *ignores* *ignorables*
  7977.                 req-vars req-anodes req-stackzs
  7978.                 opt-vars opt-anodes opt-stackzs ; optionale und svar zusammen!
  7979.                 rest-vars rest-anodes rest-stackzs
  7980.                 fixed-anodes fixed-stackz
  7981.                 reqfixed-vars reqfixed-dummys reqfixed-stackzs
  7982.                 optfixed-vars optfixed-dummys optfixed-anodes
  7983.                 optsfixed-vars optsfixed-anodes optfixed-stackzs
  7984.                 restfixed-vars restfixed-dummys restfixed-stackzs
  7985.                 aux-vars aux-anodes
  7986.                 closuredummy-stackz closuredummy-venvc
  7987.                )
  7988.             (multiple-value-setq (*specials* *ignores* *ignorables*)
  7989.               (process-declarations declarations)
  7990.             )
  7991.             ; Special-Variable auf *venv* pushen:
  7992.             (push-specials)
  7993.             (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  7994.             (setq closuredummy-stackz *stackz* closuredummy-venvc *venvc*)
  7995.             (flet ((finish-using-applyarg (reqvar optvar optinit optsvar restvar)
  7996.                      ; reqvar und optvar/optinit/optsvar sowie arglist sind schon
  7997.                      ; teilweise verkⁿrzt. Zerlegen der weiteren Argumentliste
  7998.                      ; mittels UNLIST bzw. UNLIST*. Daher ein Stackaufbau mit
  7999.                      ; festem Aussehen, vgl. c-LAMBDABODY.
  8000.                      (setq fixed-anodes
  8001.                            (list
  8002.                              (let ((anode1 (let ((*venv* oldvenv)
  8003.                                                  (*fenv* oldfenv)
  8004.                                                  (*benv* oldbenv)
  8005.                                                  (*genv* oldgenv)
  8006.                                                  (*denv* olddenv))
  8007.                                              (c-form (first applyarglist) 'ONE)
  8008.                                    )       )
  8009.                                    (anode2 (c-unlist (not (eql restvar 0))
  8010.                                                      (+ (length reqvar) (length optvar))
  8011.                                                      (length optvar)
  8012.                                   ))       )
  8013.                                (make-anode
  8014.                                  :type 'APPLY-UNLIST
  8015.                                  :sub-anodes (list anode1 anode2)
  8016.                                  :seclass (anodes-seclass-or anode1 anode2)
  8017.                                  :code `(,anode1 ,anode2)
  8018.                      )     ) ) )
  8019.                      ; Stack-Dummy-Variable fⁿr die reqvar,optvar,restvar bilden:
  8020.                      (multiple-value-setq (reqfixed-vars reqfixed-dummys)
  8021.                        (process-fixed-var-list reqvar)
  8022.                      )
  8023.                      (multiple-value-setq (optfixed-vars optfixed-dummys)
  8024.                        (process-fixed-var-list optvar)
  8025.                      )
  8026.                      (multiple-value-setq (restfixed-vars restfixed-dummys)
  8027.                        (if (eql restvar 0)
  8028.                          (values '() '())
  8029.                          (process-fixed-var-list (list restvar))
  8030.                      ) )
  8031.                      (push 0 *stackz*) (setq fixed-stackz *stackz*)
  8032.                      ; Bindungen der required-Parameter aktivieren:
  8033.                      (setq reqfixed-stackzs (bind-req-vars reqfixed-vars))
  8034.                      ; Bindungen der optional-Parameter/svar aktivieren:
  8035.                      (multiple-value-setq (optfixed-anodes optfixed-stackzs optsfixed-vars optsfixed-anodes)
  8036.                        (bind-opt-vars optfixed-vars optfixed-dummys optinit optsvar)
  8037.                      )
  8038.                      ; Bindung des rest-Parameters aktivieren:
  8039.                      (unless (eql restvar 0)
  8040.                        (setq restfixed-stackzs (bind-rest-vars restfixed-vars))
  8041.                      )
  8042.                   ))
  8043.               (block main-args
  8044.                 ; required-Parameter binden:
  8045.                 (do ((reqvarr reqvar (cdr reqvarr)))
  8046.                     ((null reqvarr))
  8047.                   (if (null arglist) ; impliziert, da▀ apply-arg da
  8048.                     (return-from main-args
  8049.                       (finish-using-applyarg reqvarr optvar optinit optsvar restvar)
  8050.                     )
  8051.                     (let* ((form (pop arglist))
  8052.                            (anode (let ((*venv* oldvenv)
  8053.                                         (*fenv* oldfenv)
  8054.                                         (*benv* oldbenv)
  8055.                                         (*genv* oldgenv)
  8056.                                         (*denv* olddenv))
  8057.                                     (c-form form 'ONE)
  8058.                            )      )
  8059.                            (var (bind-movable-var (car reqvarr) anode)))
  8060.                       (push anode req-anodes)
  8061.                       (push var req-vars)
  8062.                       (push *stackz* req-stackzs)
  8063.                       (push-*venv* var)
  8064.                 ) ) )
  8065.                 ; optionale Parameter und Svars binden:
  8066.                 (do ((optvarr optvar (cdr optvarr))
  8067.                      (optinitr optinit (cdr optinitr))
  8068.                      (optsvarr optsvar (cdr optsvarr)))
  8069.                     ((null optvarr))
  8070.                   (if (and applyarglist (null arglist))
  8071.                     (return-from main-args
  8072.                       (finish-using-applyarg '() optvarr optinitr optsvarr restvar)
  8073.                     )
  8074.                     (let* ((svar-init (not (null arglist))) ; = NIL oder T
  8075.                            (anode (if svar-init
  8076.                                     (progn
  8077.                                       (let ((*no-code* t))
  8078.                                         (c-form (car optinitr) 'NIL)
  8079.                                       )
  8080.                                       (let ((*venv* oldvenv)
  8081.                                             (*fenv* oldfenv)
  8082.                                             (*benv* oldbenv)
  8083.                                             (*genv* oldgenv)
  8084.                                             (*denv* olddenv))
  8085.                                         (c-form (pop arglist) 'ONE)
  8086.                                     ) )
  8087.                                     (c-form (car optinitr) 'ONE)
  8088.                            )      )
  8089.                            (var (bind-movable-var (car optvarr) anode)))
  8090.                       (push anode opt-anodes)
  8091.                       (push var opt-vars)
  8092.                       (push *stackz* opt-stackzs)
  8093.                       (push-*venv* var)
  8094.                       (unless (eql (car optsvarr) 0)
  8095.                         (let* ((anode (c-form svar-init 'ONE))
  8096.                                (var (bind-movable-var (car optsvarr) anode)))
  8097.                           (push anode opt-anodes)
  8098.                           (push var opt-vars)
  8099.                           (push *stackz* opt-stackzs)
  8100.                           (push-*venv* var)
  8101.                       ) )
  8102.                 ) ) )
  8103.                 (if (eql restvar 0)
  8104.                   ; weitere Argumente verbrauchen:
  8105.                   (when applyarglist
  8106.                     (return-from main-args
  8107.                       (finish-using-applyarg '() '() '() '() restvar)
  8108.                   ) )
  8109.                   ; Rest-Parameter binden:
  8110.                   (let* ((form (if applyarglist
  8111.                                  (if arglist `(LIST* ,@arglist ,@applyarglist) (first applyarglist))
  8112.                                  (if arglist `(LIST ,@arglist) 'NIL)
  8113.                          )     )
  8114.                          (anode (let ((*venv* oldvenv)
  8115.                                       (*fenv* oldfenv)
  8116.                                       (*benv* oldbenv)
  8117.                                       (*genv* oldgenv)
  8118.                                       (*denv* olddenv))
  8119.                                   (c-form form 'ONE)
  8120.                          )      )
  8121.                          (var (bind-movable-var restvar anode)))
  8122.                     (push anode rest-anodes)
  8123.                     (push var rest-vars)
  8124.                     (push *stackz* rest-stackzs)
  8125.                     (push-*venv* var)
  8126.                 ) )
  8127.                 (push 0 *stackz*) (setq fixed-stackz *stackz*)
  8128.             ) )
  8129.             (setq req-vars (nreverse req-vars))
  8130.             (setq req-anodes (nreverse req-anodes))
  8131.             (setq req-stackzs (nreverse req-stackzs))
  8132.             (setq opt-vars (nreverse opt-vars))
  8133.             (setq opt-anodes (nreverse opt-anodes))
  8134.             (setq opt-stackzs (nreverse opt-stackzs))
  8135.             ; Bindungen der Aux-Variablen aktivieren:
  8136.             (multiple-value-setq (aux-vars aux-anodes)
  8137.               (bind-aux-vars auxvar auxinit)
  8138.             )
  8139.             (let* ((body-anode (c-form `(PROGN ,@body-rest)))
  8140.                    ; ▄berprⁿfen der Variablen:
  8141.                    (varlist
  8142.                      (append req-vars opt-vars rest-vars
  8143.                              reqfixed-vars optfixed-vars optsfixed-vars restfixed-vars
  8144.                              aux-vars
  8145.                    ) )
  8146.                    (closurevars
  8147.                      (append
  8148.                        (checking-movable-var-list req-vars req-anodes)
  8149.                        (checking-movable-var-list opt-vars opt-anodes)
  8150.                        (checking-movable-var-list rest-vars rest-anodes)
  8151.                        (checking-fixed-var-list reqfixed-vars)
  8152.                        (checking-fixed-var-list optfixed-vars)
  8153.                        (checking-movable-var-list optsfixed-vars optsfixed-anodes)
  8154.                        (checking-fixed-var-list restfixed-vars)
  8155.                        (checking-movable-var-list aux-vars aux-anodes)
  8156.                    ) )
  8157.                    (codelist
  8158.                      `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  8159.                        ,@(let ((*stackz* fixed-stackz))
  8160.                            (c-parallel-bind-movable-var-anode
  8161.                              (append req-vars    opt-vars    rest-vars   )
  8162.                              (append req-anodes  opt-anodes  rest-anodes )
  8163.                              (append req-stackzs opt-stackzs rest-stackzs)
  8164.                              fixed-anodes
  8165.                          ) )
  8166.                        ,@(mapcap #'c-bind-fixed-var reqfixed-vars reqfixed-dummys reqfixed-stackzs)
  8167.                        ,@(c-bind-with-svars optfixed-vars optfixed-dummys optsfixed-vars optfixed-anodes optsfixed-anodes optfixed-stackzs)
  8168.                        ,@(mapcap #'c-bind-fixed-var restfixed-vars restfixed-dummys restfixed-stackzs)
  8169.                        ,@(mapcap #'c-bind-movable-var-anode aux-vars aux-anodes)
  8170.                        ,body-anode
  8171.                        (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  8172.                    )  )
  8173.                    (anode
  8174.                      (make-anode
  8175.                        :type 'FUNCALL
  8176.                        :sub-anodes
  8177.                          `(,@req-anodes ,@opt-anodes ,@rest-anodes
  8178.                            ,@fixed-anodes ,@optfixed-anodes ,@(remove nil optsfixed-anodes)
  8179.                            ,@aux-anodes ,body-anode
  8180.                           )
  8181.                        :seclass
  8182.                          (seclass-without
  8183.                            (anodelist-seclass-or
  8184.                              `(,@req-anodes ,@opt-anodes ,@rest-anodes
  8185.                                ,@fixed-anodes ,@optfixed-anodes ,@(remove nil optsfixed-anodes)
  8186.                                ,@aux-anodes ,body-anode
  8187.                            )  )
  8188.                            varlist
  8189.                          )
  8190.                        :stackz oldstackz
  8191.                        :code codelist
  8192.                   )) )
  8193.               (when closurevars
  8194.                 (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  8195.                 (setf (first closuredummy-venvc)
  8196.                   (cons closurevars closuredummy-stackz)
  8197.               ) )
  8198.               (optimize-var-list varlist)
  8199.               anode
  8200. ) ) ) ) ) ) )
  8201.  
  8202. ; compiliert (fun {form}*), wobei fun eine lokale Funktion ist.
  8203. ; fdescr die zugeh÷rige Information aus *fenv*.
  8204. (defun c-LOCAL-FUNCTION-CALL (fun fdescr args)
  8205.   ; (test-list args 0) ; das erledigt gleich (test-argument-syntax ...)
  8206.   ; Aufruf-Spezifikation holen:
  8207.   (multiple-value-bind (req opt rest-flag key-flag keylist allow-flag)
  8208.       (fdescr-signature fdescr)
  8209.     (case (test-argument-syntax
  8210.             args nil fun req opt rest-flag key-flag keylist allow-flag
  8211.           )
  8212.       ((NO-KEYS STATIC-KEYS)
  8213.        ; Aufruf INLINE
  8214.        (c-DIRECT-FUNCTION-CALL
  8215.          args nil fun req opt rest-flag key-flag keylist
  8216.          nil ; kein SUBR-, sondern Cclosure-Aufruf
  8217.          (cclosure-call-code-producer fun (car fdescr) req opt rest-flag key-flag keylist)
  8218.       ))
  8219.       (t (c-FUNCALL-NOTINLINE `(FUNCTION ,fun) args))
  8220. ) ) )
  8221.  
  8222. ; (c-FUNCTION-CALL funform arglist) compiliert einen Funktionsaufruf
  8223. ; (SYS::%FUNCALL funform . arglist).
  8224. (defun c-FUNCTION-CALL (funform arglist)
  8225.   (setq funform (macroexpand-form funform))
  8226.   (when (inline-callable-function-lambda-p funform (length arglist))
  8227.     ; Aufruf eines Lambda-Ausdrucks INLINE m÷glich
  8228.     (return-from c-FUNCTION-CALL
  8229.       (c-FUNCALL-INLINE funform arglist nil (cdr (second funform)) t)
  8230.   ) )
  8231.   (when (and (consp funform) (eq (first funform) 'COMPLEMENT)
  8232.              (consp (rest funform)) (null (cddr funform))
  8233.              (not (fenv-search 'COMPLEMENT)) (not (declared-notinline 'COMPLEMENT))
  8234.              (not (fenv-search 'NOT))
  8235.         )
  8236.     ; (complement fn) --> (let ((f fn)) ... #'(lambda (&rest args) (not (apply f args))) ...)
  8237.     (return-from c-FUNCTION-CALL
  8238.       (c-form `(NOT (SYS::%FUNCALL ,(second funform) ,@arglist)))
  8239.   ) )
  8240.   (when (and (consp funform) (eq (first funform) 'CONSTANTLY)
  8241.              (consp (rest funform)) (null (cddr funform))
  8242.              (not (fenv-search 'CONSTANTLY)) (not (declared-notinline 'CONSTANTLY))
  8243.         )
  8244.     ; (constantly obj) --> (let ((o obj)) ... #'(lambda (&rest args) (declare (ignore args)) o) ...)
  8245.     (return-from c-FUNCTION-CALL
  8246.       (c-form `(PROG1 ,(second funform) ,@arglist))
  8247.   ) )
  8248.   (when (and (consp funform) (eq (first funform) 'FUNCTION)
  8249.              ; Ausdrⁿcke der Form (FUNCTION ...) dⁿrfen zu beliebigem
  8250.              ; Zeitpunkt ausgewertet werden, also ist
  8251.              ; (SYS::%FUNCALL (FUNCTION fun) . arglist)  Σquivalent zu
  8252.              ; (fun . arglist).
  8253.              (consp (rest funform)) (function-name-p (second funform)) ; vorerst nur #'sym, sonst Endlosschleife!
  8254.         )
  8255.     (return-from c-FUNCTION-CALL
  8256.       (progn
  8257.         (test-list funform 2 2)
  8258.         (c-form `(,(second funform) ,@arglist)) ; genauer aufschlⁿsseln, vgl. c-FUNCTION ??
  8259.   ) ) )
  8260.   ; Aufruf NOTINLINE
  8261.   (c-FUNCALL-NOTINLINE funform arglist)
  8262. )
  8263.  
  8264. (defun c-FUNCALL ()
  8265.   (test-list *form* 2)
  8266.   (c-FUNCTION-CALL (second *form*) (cddr *form*))
  8267. )
  8268.  
  8269. (defun c-APPLY ()
  8270.   (test-list *form* 3)
  8271.   (let* ((funform (second *form*))
  8272.          (arglist (cddr *form*))
  8273.          (n (1- (length arglist)))) ; Mindestanzahl Argumente
  8274.     (setq funform (macroexpand-form funform))
  8275.     (when (inline-callable-function-lambda-p funform n t)
  8276.       ; Aufruf eines Lambda-Ausdrucks INLINE m÷glich
  8277.       (return-from c-APPLY
  8278.         (c-FUNCALL-INLINE funform (butlast arglist) (last arglist) (cdr (second funform)) t)
  8279.     ) )
  8280.     (when (and (consp funform) (eq (first funform) 'COMPLEMENT)
  8281.                (consp (rest funform)) (null (cddr funform))
  8282.                (not (fenv-search 'COMPLEMENT)) (not (declared-notinline 'COMPLEMENT))
  8283.                (not (fenv-search 'NOT))
  8284.           )
  8285.       ; (complement fn) --> (let ((f fn)) ... #'(lambda (&rest args) (not (apply f args))) ...)
  8286.       (return-from c-APPLY
  8287.         (c-form `(NOT (APPLY ,(second funform) ,@arglist)))
  8288.     ) )
  8289.     (when (and (consp funform) (eq (first funform) 'CONSTANTLY)
  8290.                (consp (rest funform)) (null (cddr funform))
  8291.                (not (fenv-search 'CONSTANTLY)) (not (declared-notinline 'CONSTANTLY))
  8292.           )
  8293.       ; (constantly obj) --> (let ((o obj)) ... #'(lambda (&rest args) (declare (ignore args)) o) ...)
  8294.       (return-from c-APPLY
  8295.         (c-form `(PROG1 ,(second funform) ,@arglist))
  8296.     ) )
  8297.     (when (and (consp funform) (eq (first funform) 'FUNCTION)
  8298.                ; Ausdrⁿcke der Form (FUNCTION ...) dⁿrfen zu beliebigem
  8299.                ; Zeitpunkt ausgewertet werden.
  8300.                (consp (rest funform)) (function-name-p (second funform))
  8301.           )
  8302.       (let ((fun (second funform)))
  8303.         (test-list funform 2 2)
  8304.         (unless (declared-notinline fun) ; darf fun INLINE genommen werden?
  8305.           (flet ((c-LOCAL-APPLY (fdescr)
  8306.                    (multiple-value-bind (req opt rest-flag key-flag keylist allow-flag)
  8307.                        (fdescr-signature fdescr)
  8308.                      (unless key-flag
  8309.                        ; ohne Keyword-Argumente
  8310.                        (when (eq (test-argument-syntax (butlast arglist) (last arglist)
  8311.                                    fun req opt rest-flag key-flag keylist allow-flag
  8312.                                  )
  8313.                                'NO-KEYS
  8314.                              )
  8315.                          ; Syntax stimmt -> Aufruf INLINE
  8316.                          (return-from c-APPLY
  8317.                            (c-DIRECT-FUNCTION-CALL (butlast arglist) (last arglist)
  8318.                              fun req opt rest-flag key-flag keylist
  8319.                              nil ; kein SUBR-, sondern Cclosure-Aufruf
  8320.                              (cclosure-call-code-producer fun (car fdescr) req opt rest-flag key-flag keylist)
  8321.                 )) ) ) ) ) )
  8322.             (multiple-value-bind (a b c) (fenv-search fun)
  8323.               (declare (ignore b))
  8324.               ; (APPLY #'fun . args) kann evtl. vereinfacht werden
  8325.               (case a
  8326.                 ((NIL) ; globale Funktion
  8327.                   (unless (and (symbolp fun) (or (special-form-p fun) (macro-function fun))) ; Special-Form oder globaler Macro ?
  8328.                     (when (and (equal fun (fnode-name *func*))
  8329.                                (member `(SYS::IN-DEFUN ,fun) *denv* :test #'equal)
  8330.                           )
  8331.                       ; rekursiver Aufruf der aktuellen globalen Funktion
  8332.                       (c-LOCAL-APPLY (cons *func* nil))
  8333.                     )
  8334.                     (let ((inline-lambdabody
  8335.                             (or (and *compiling-from-file*
  8336.                                      (cdr (assoc fun *inline-definitions* :test #'equal))
  8337.                                 )
  8338.                                 (get (get-funname-symbol fun) 'sys::inline-expansion)
  8339.                          )) )
  8340.                       (if (and #| inline-lambdabody |#
  8341.                                (consp inline-lambdabody)
  8342.                                (inline-callable-function-lambda-p `(FUNCTION (LAMBDA ,@inline-lambdabody)) n t)
  8343.                           )
  8344.                         ; Aufruf einer globalen Funktion INLINE m÷glich
  8345.                         (return-from c-APPLY
  8346.                           (c-FUNCALL-INLINE fun (butlast arglist) (last arglist) inline-lambdabody nil)
  8347.                 ) ) ) ) )
  8348.                 (LOCAL ; lokale Funktion
  8349.                   (c-LOCAL-APPLY c)
  8350.               ) )
  8351.     ) ) ) ) )
  8352.     ; Wenn keine der Optimierungen m÷glich war:
  8353.     (let* ((anode1 (c-form funform 'ONE))
  8354.            (*stackz* (cons 1 *stackz*)))
  8355.       (do ((formlistr arglist (cdr formlistr))
  8356.            #+COMPILER-DEBUG (anodelist (list anode1))
  8357.            (codelist (list '(APPLYP) anode1)))
  8358.           ((null formlistr)
  8359.            (push `(APPLY ,n) codelist)
  8360.            (make-anode
  8361.              :type 'APPLY
  8362.              :sub-anodes (nreverse anodelist)
  8363.              :seclass '(T . T)
  8364.              :code (nreverse codelist)
  8365.           ))
  8366.         (let ((anode (c-form (car formlistr) 'ONE)))
  8367.           #+COMPILER-DEBUG (push anode anodelist)
  8368.           (push anode codelist)
  8369.           (when (cdr formlistr)
  8370.             (push 1 *stackz*) (push '(PUSH) codelist)
  8371.     ) ) ) )
  8372. ) )
  8373.  
  8374. (defun c-PLUS ()
  8375.   (test-list *form* 1)
  8376.   ; bilde Teilsumme der konstanten Argumente, Rest dann dazu:
  8377.   (let ((const-sum 0)
  8378.         (other-parts '())
  8379.         val
  8380.        )
  8381.     (dolist (form (cdr *form*))
  8382.       (setq form (macroexpand-form form))
  8383.       (if (and (c-constantp form) (numberp (setq val (c-constant-value form))))
  8384.         (setq const-sum (+ const-sum val))
  8385.         (push form other-parts)
  8386.     ) )
  8387.     (case (length other-parts)
  8388.       (0 ; nur konstante Summanden
  8389.          (c-form const-sum) ; Zahl const-sum wertet zu sich selbst aus
  8390.       )
  8391.       (1 ; nur ein variabler Summand
  8392.          (case const-sum
  8393.            (0 (c-form (first other-parts))) ; keine Addition n÷tig
  8394.            (+1 (c-form `(1+ ,(first other-parts))))
  8395.            (-1 (c-form `(1- ,(first other-parts))))
  8396.            (t (c-GLOBAL-FUNCTION-CALL-form `(+ ,const-sum ,@other-parts)))
  8397.       )  )
  8398.       (t (setq other-parts (nreverse other-parts))
  8399.          (unless (eql const-sum 0) (push const-sum other-parts))
  8400.          (c-GLOBAL-FUNCTION-CALL-form `(+ ,@other-parts))
  8401. ) ) ) )
  8402.  
  8403. (defun c-MINUS ()
  8404.   (test-list *form* 2)
  8405.   (let ((unary-p (= (length *form*) 2)) ; unΣres Minus oder nicht?
  8406.         (const-sum 0) ; Summe der konstanten Teile
  8407.         (first-part 0) ; zu addierende Form
  8408.         (other-parts '()) ; abzuziehende Formen
  8409.         val
  8410.        )
  8411.     (unless unary-p
  8412.       (let ((form (macroexpand-form (second *form*))))
  8413.         (if (and (c-constantp form) (numberp (setq val (c-constant-value form))))
  8414.           (setq const-sum val)
  8415.           (setq first-part form)
  8416.     ) ) )
  8417.     (dolist (form (if unary-p (cdr *form*) (cddr *form*)))
  8418.       (setq form (macroexpand-form form))
  8419.       (if (and (c-constantp form) (numberp (setq val (c-constant-value form))))
  8420.         (setq const-sum (- const-sum val))
  8421.         (push form other-parts)
  8422.     ) )
  8423.     (if (null other-parts)
  8424.       ; nichts zu subtrahieren
  8425.       (let ((*form* `(+ ,const-sum ,first-part))) (c-PLUS))
  8426.       ; etwas zu subtrahieren
  8427.       (c-GLOBAL-FUNCTION-CALL-form
  8428.         `(-
  8429.           ,@(if (eql first-part 0) ; variable zu addierende Form?
  8430.               (if (and (eql const-sum 0) (null (cdr other-parts)))
  8431.                 '()
  8432.                 `(,const-sum)
  8433.               )
  8434.               (if (eql const-sum 0)
  8435.                 `(,first-part)
  8436.                 `(,first-part ,(- const-sum))
  8437.             ) )
  8438.           ,@(nreverse other-parts)
  8439.          )
  8440. ) ) ) )
  8441.  
  8442. (defun c-SVSTORE ()
  8443.   (test-list *form* 4 4)
  8444.   ; (sys::svstore arg1 arg2 arg3) -> (sys::%svstore arg3 arg1 arg2)
  8445.   (let ((arg1 (second *form*)) (arg2 (third *form*)) (arg3 (fourth *form*))
  8446.         (argvar1 (gensym)) (argvar2 (gensym)))
  8447.     (c-form
  8448.       `(LET* ((,argvar1 ,arg1) (,argvar2 ,arg2))
  8449.          (sys::%svstore ,arg3 ,argvar1 ,argvar2)
  8450.        )
  8451. ) ) )
  8452.  
  8453. (defun c-EQ ()
  8454.   (test-list *form* 3 3)
  8455.   (let ((arg1 (macroexpand-form (second *form*)))
  8456.         (arg2 (macroexpand-form (third *form*))))
  8457.     (if (and (c-constantp arg1) (c-constantp arg2))
  8458.       (c-form `(QUOTE ,(eq (c-constant-value arg1) (c-constant-value arg2))))
  8459.       (progn
  8460.         (when (c-constantp arg1)
  8461.           (rotatef arg1 arg2) ; Besser arg2 konstant, damit JMPIFEQTO geht
  8462.         )
  8463.         (if (and (c-constantp arg2) (eq (c-constant-value arg2) 'NIL))
  8464.           (c-GLOBAL-FUNCTION-CALL-form `(NULL ,arg1))
  8465.           (c-GLOBAL-FUNCTION-CALL-form `(EQ ,arg1 ,arg2))
  8466. ) ) ) ) )
  8467.  
  8468. ; bei Symbolen, Fixnums und Characters ist EQL mit EQ gleichbedeutend
  8469. (defun EQL=EQ (x) (or (symbolp x) (fixnump x) (characterp x)))
  8470.  
  8471. (defun c-EQL ()
  8472.   (test-list *form* 3 3)
  8473.   (let ((arg1 (macroexpand-form (second *form*)))
  8474.         (arg2 (macroexpand-form (third *form*))))
  8475.     (cond ((and (c-constantp arg1) (c-constantp arg2))
  8476.            (c-form `(QUOTE ,(eql (c-constant-value arg1) (c-constant-value arg2))))
  8477.           )
  8478.           ((or (and (c-constantp arg1) (EQL=EQ (c-constant-value arg1)))
  8479.                (and (c-constantp arg2) (EQL=EQ (c-constant-value arg2)))
  8480.            )
  8481.            (let ((*form* `(EQ ,arg1 ,arg2))) (c-EQ))
  8482.           )
  8483.           (t (c-GLOBAL-FUNCTION-CALL-form `(EQL ,arg1 ,arg2)))
  8484. ) ) )
  8485.  
  8486. ; bei Symbolen, Zahlen und Characters ist EQUAL mit EQL gleichbedeutend
  8487. (defun EQUAL=EQL (x) (or (symbolp x) (numberp x) (characterp x)))
  8488.  
  8489. (defun c-EQUAL ()
  8490.   (test-list *form* 3 3)
  8491.   (let ((arg1 (macroexpand-form (second *form*)))
  8492.         (arg2 (macroexpand-form (third *form*))))
  8493.     (cond ((or (and (c-constantp arg1) (EQUAL=EQL (c-constant-value arg1)))
  8494.                (and (c-constantp arg2) (EQUAL=EQL (c-constant-value arg2)))
  8495.            )
  8496.            (let ((*form* `(EQL ,arg1 ,arg2))) (c-EQL))
  8497.           )
  8498.           (t (c-GLOBAL-FUNCTION-CALL-form `(EQUAL ,arg1 ,arg2)))
  8499. ) ) )
  8500.  
  8501. ; Bildet den inneren Teil einer MAPCAR/MAPC/MAPCAN/MAPCAP-Expansion
  8502. (defun c-MAP-on-CARs-inner (innerst-fun blockname restvars &optional (itemvars '()))
  8503.   (if (null restvars)
  8504.     (funcall innerst-fun (nreverse itemvars))
  8505.     (let ((restvar (car restvars))
  8506.           (itemvar (gensym)))
  8507.       `(IF (CONSP ,restvar)
  8508.          (LET ((,itemvar (CAR ,restvar)))
  8509.            ,(c-MAP-on-CARs-inner innerst-fun blockname (cdr restvars) (cons itemvar itemvars))
  8510.          )
  8511.          (RETURN-FROM ,blockname)
  8512. ) ) )  )
  8513.  
  8514. ; Bildet eine MAPCAR/MAPCAN/MAPCAP-Expansion
  8515. (defun c-MAP-on-CARs (adjoin-fun funform forms)
  8516.   (let ((erg (gensym))
  8517.         (blockname (gensym))
  8518.         (restvars
  8519.           (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8520.         )
  8521.         (tag (gensym)))
  8522.     `(LET ((,erg NIL))
  8523.        (BLOCK ,blockname
  8524.          (LET* ,(mapcar #'list restvars forms)
  8525.            (TAGBODY ,tag
  8526.              ,(c-MAP-on-CARs-inner
  8527.                 #'(lambda (itemvars)
  8528.                     `(SETQ ,erg (,adjoin-fun (SYS::%FUNCALL ,funform ,@itemvars) ,erg))
  8529.                   )
  8530.                 blockname
  8531.                 restvars
  8532.               )
  8533.              (SETQ ,@(mapcap #'(lambda (restvar)
  8534.                                  `(,restvar (CDR ,restvar))
  8535.                                )
  8536.                              restvars
  8537.              )       )
  8538.              (GO ,tag)
  8539.        ) ) )
  8540.        (SYS::LIST-NREVERSE ,erg)
  8541. ) )  )
  8542.  
  8543. ; Bildet eine MAPLIST/MAPCON/MAPLAP-Expansion
  8544. (defun c-MAP-on-LISTs (adjoin-fun funform forms)
  8545.   (let ((erg (gensym))
  8546.         (blockname (gensym))
  8547.         (restvars
  8548.           (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8549.         )
  8550.         (tag (gensym)))
  8551.     `(LET ((,erg NIL))
  8552.        (BLOCK ,blockname
  8553.          (LET* ,(mapcar #'list restvars forms)
  8554.            (TAGBODY ,tag
  8555.              (IF (OR ,@(mapcar #'(lambda (restvar) `(ATOM ,restvar)) restvars))
  8556.                (RETURN-FROM ,blockname)
  8557.              )
  8558.              (SETQ ,erg (,adjoin-fun (SYS::%FUNCALL ,funform ,@restvars) ,erg))
  8559.              (SETQ ,@(mapcap #'(lambda (restvar)
  8560.                                  `(,restvar (CDR ,restvar))
  8561.                                )
  8562.                              restvars
  8563.              )       )
  8564.              (GO ,tag)
  8565.        ) ) )
  8566.        (SYS::LIST-NREVERSE ,erg)
  8567. ) )  )
  8568.  
  8569. (defun c-MAPC ()
  8570.   (test-list *form* 3)
  8571.   (let ((funform (macroexpand-form (second *form*))))
  8572.     (if (inline-callable-function-p funform (length (cddr *form*)))
  8573.       (c-form
  8574.         (let* ((tempvar (gensym))
  8575.                (forms (cons tempvar (cdddr *form*)))
  8576.                (blockname (gensym))
  8577.                (restvars
  8578.                  (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8579.                )
  8580.                (tag (gensym)))
  8581.           `(LET ((,tempvar ,(third *form*)))
  8582.              (BLOCK ,blockname
  8583.                (LET* ,(mapcar #'list restvars forms)
  8584.                  (TAGBODY ,tag
  8585.                    ,(c-MAP-on-CARs-inner
  8586.                       #'(lambda (itemvars) `(SYS::%FUNCALL ,funform ,@itemvars))
  8587.                       blockname
  8588.                       restvars
  8589.                     )
  8590.                    (SETQ ,@(mapcap #'(lambda (restvar)
  8591.                                        `(,restvar (CDR ,restvar))
  8592.                                      )
  8593.                                    restvars
  8594.                    )       )
  8595.                    (GO ,tag)
  8596.              ) ) )
  8597.              ,tempvar
  8598.       ) )  )
  8599.       (c-GLOBAL-FUNCTION-CALL-form `(MAPC ,funform ,@(cddr *form*)))
  8600. ) ) )
  8601.  
  8602. (defun c-MAPL ()
  8603.   (test-list *form* 3)
  8604.   (let ((funform (macroexpand-form (second *form*))))
  8605.     (if (inline-callable-function-p funform (length (cddr *form*)))
  8606.       (c-form
  8607.         (let* ((tempvar (gensym))
  8608.                (forms (cons tempvar (cdddr *form*)))
  8609.                (blockname (gensym))
  8610.                (restvars
  8611.                  (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8612.                )
  8613.                (tag (gensym)))
  8614.           `(LET ((,tempvar ,(third *form*)))
  8615.              (BLOCK ,blockname
  8616.                (LET* ,(mapcar #'list restvars forms)
  8617.                  (TAGBODY ,tag
  8618.                    (IF (OR ,@(mapcar #'(lambda (restvar) `(ATOM ,restvar)) restvars))
  8619.                      (RETURN-FROM ,blockname)
  8620.                    )
  8621.                    (SYS::%FUNCALL ,funform ,@restvars)
  8622.                    (SETQ ,@(mapcap #'(lambda (restvar)
  8623.                                        `(,restvar (CDR ,restvar))
  8624.                                      )
  8625.                                    restvars
  8626.                    )       )
  8627.                    (GO ,tag)
  8628.              ) ) )
  8629.              ,tempvar
  8630.       ) )  )
  8631.       (c-GLOBAL-FUNCTION-CALL-form `(MAPL ,funform ,@(cddr *form*)))
  8632. ) ) )
  8633.  
  8634. (defun c-MAPCAR ()
  8635.   (test-list *form* 3)
  8636.   (if (null *for-value*)
  8637.     (let ((*form* `(MAPC ,@(cdr *form*)))) (c-MAPC))
  8638.     (let ((funform (macroexpand-form (second *form*)))
  8639.           (forms (cddr *form*)))
  8640.       (if (inline-callable-function-p funform (length forms))
  8641.         (c-form (c-MAP-on-CARs 'CONS funform forms))
  8642.         (c-GLOBAL-FUNCTION-CALL-form `(MAPCAR ,funform ,@forms))
  8643. ) ) ) )
  8644.  
  8645. (defun c-MAPLIST ()
  8646.   (test-list *form* 3)
  8647.   (if (null *for-value*)
  8648.     (let ((*form* `(MAPL ,@(cdr *form*)))) (c-MAPL))
  8649.     (let ((funform (macroexpand-form (second *form*)))
  8650.           (forms (cddr *form*)))
  8651.       (if (inline-callable-function-p funform (length forms))
  8652.         (c-form (c-MAP-on-LISTs 'CONS funform forms))
  8653.         (c-GLOBAL-FUNCTION-CALL-form `(MAPLIST ,funform ,@forms))
  8654. ) ) ) )
  8655.  
  8656. (defun c-MAPCAN ()
  8657.   (test-list *form* 3)
  8658.   (let ((funform (macroexpand-form (second *form*)))
  8659.         (forms (cddr *form*)))
  8660.     (if (inline-callable-function-p funform (length forms))
  8661.       (c-form (c-MAP-on-CARs 'NRECONC funform forms))
  8662.       (c-GLOBAL-FUNCTION-CALL-form `(MAPCAN ,funform ,@forms))
  8663. ) ) )
  8664.  
  8665. (defun c-MAPCON ()
  8666.   (test-list *form* 3)
  8667.   (let ((funform (macroexpand-form (second *form*)))
  8668.         (forms (cddr *form*)))
  8669.     (if (inline-callable-function-p funform (length forms))
  8670.       (c-form (c-MAP-on-LISTs 'NRECONC funform forms))
  8671.       (c-GLOBAL-FUNCTION-CALL-form `(MAPCON ,funform ,@forms))
  8672. ) ) )
  8673.  
  8674. (defun c-MAPCAP ()
  8675.   (test-list *form* 3)
  8676.   (if (null *for-value*)
  8677.     (let ((*form* `(MAPC ,@(cdr *form*)))) (c-MAPC))
  8678.     (let ((funform (macroexpand-form (second *form*)))
  8679.           (forms (cddr *form*)))
  8680.       (if (inline-callable-function-p funform (length forms))
  8681.         (c-form (c-MAP-on-CARs 'REVAPPEND funform forms))
  8682.         (c-GLOBAL-FUNCTION-CALL-form `(MAPCAP ,funform ,@forms))
  8683. ) ) ) )
  8684.  
  8685. (defun c-MAPLAP ()
  8686.   (test-list *form* 3)
  8687.   (if (null *for-value*)
  8688.     (let ((*form* `(MAPL ,@(cdr *form*)))) (c-MAPL))
  8689.     (let ((funform (macroexpand-form (second *form*)))
  8690.           (forms (cddr *form*)))
  8691.       (if (inline-callable-function-p funform (length forms))
  8692.         (c-form (c-MAP-on-LISTs 'REVAPPEND funform forms))
  8693.         (c-GLOBAL-FUNCTION-CALL-form `(MAPLAP ,funform ,@forms))
  8694. ) ) ) )
  8695.  
  8696. ;; c-TYPEP vgl. TYPEP in type.lsp
  8697. ; Symbole mit Property TYPE-SYMBOL:
  8698. (defconstant c-typep-alist1
  8699.   '((ARRAY . arrayp)
  8700.     (ATOM . atom)
  8701.     (BIT-VECTOR . bit-vector-p)
  8702.     (CHARACTER . characterp)
  8703.     (COMMON . commonp)
  8704.     (COMPILED-FUNCTION . compiled-function-p)
  8705.     (COMPLEX . complexp)
  8706.     (CONS . consp)
  8707.     (DOUBLE-FLOAT . double-float-p)
  8708.     (FIXNUM . fixnump)
  8709.     (FLOAT . floatp)
  8710.     (FUNCTION . functionp)
  8711.     (HASH-TABLE . hash-table-p)
  8712.     (INTEGER . integerp)
  8713.     (KEYWORD . keywordp)
  8714.     (LIST . listp)
  8715.     #+LOGICAL-PATHNAMES
  8716.     (LOGICAL-PATHNAME . sys::logical-pathname-p)
  8717.     (LONG-FLOAT . long-float-p)
  8718.     (NULL . null)
  8719.     (NUMBER . numberp)
  8720.     (PACKAGE . packagep)
  8721.     (PATHNAME . pathnamep)
  8722.     (RANDOM-STATE . random-state-p)
  8723.     (RATIONAL . rationalp)
  8724.     (READTABLE . readtablep)
  8725.     (REAL . realp)
  8726.     (SEQUENCE . sys::sequencep)
  8727.     (SHORT-FLOAT . short-float-p)
  8728.     (SIMPLE-ARRAY . sys::simple-array-p)
  8729.     (SIMPLE-BIT-VECTOR . simple-bit-vector-p)
  8730.     (SIMPLE-STRING . simple-string-p)
  8731.     (SIMPLE-VECTOR . simple-vector-p)
  8732.     (SINGLE-FLOAT . single-float-p)
  8733.     (CLOS:STANDARD-GENERIC-FUNCTION . clos::generic-function-p)
  8734.     (CLOS:STANDARD-OBJECT . clos::std-instance-p)
  8735.     (STREAM . streamp)
  8736.     (FILE-STREAM . sys::file-stream-p)
  8737.     (SYNONYM-STREAM . sys::synonym-stream-p)
  8738.     (BROADCAST-STREAM . sys::broadcast-stream-p)
  8739.     (CONCATENATED-STREAM . sys::concatenated-stream-p)
  8740.     (TWO-WAY-STREAM . sys::two-way-stream-p)
  8741.     (ECHO-STREAM . sys::echo-stream-p)
  8742.     (STRING-STREAM . sys::string-stream-p)
  8743.     (STRING . stringp)
  8744.     (CLOS::STRUCTURE-OBJECT . clos::structure-instance-p)
  8745.     (SYMBOL . symbolp)
  8746.     (VECTOR . vectorp)
  8747. )  )
  8748. (defconstant c-typep-alist2
  8749.   '((BIGNUM . ((x) (and (integerp x) (not (fixnump x)))))
  8750.     (BIT . ((x) (or (eql x 0) (eql x 1))))
  8751.     (NIL . ((x) (declare (ignore x)) nil))
  8752.     (RATIO . ((x) (and (rationalp x) (not (integerp x)))))
  8753.     (STANDARD-CHAR . ((x) (and (characterp x) (standard-char-p x))))
  8754.     (STRING-CHAR . ((x) (and (characterp x) (string-char-p x))))
  8755.     (STRUCTURE .
  8756.       ((x)
  8757.         (let ((y (type-of x)))
  8758.           (and (symbolp y) (get y 'SYS::DEFSTRUCT-DESCRIPTION)
  8759.                (SYS::%STRUCTURE-TYPE-P y x)
  8760.     ) ) ) )
  8761.     (T . ((x) (declare (ignore x)) t))
  8762. )  )
  8763. (defun c-typep-array (tester)
  8764.   #'(lambda (x &optional (el-type '*) (dims '*) &rest illegal-args)
  8765.       (declare (ignore illegal-args))
  8766.       `(AND (,tester ,x)
  8767.             ,@(if (eq el-type '*)
  8768.                 '()
  8769.                 `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
  8770.               )
  8771.             ,@(if (eq dims '*)
  8772.                 '()
  8773.                 (if (numberp dims)
  8774.                   `((EQL ,dims (ARRAY-RANK ,x)))
  8775.                   `((EQL ,(length dims) (ARRAY-RANK ,x))
  8776.                     ,@(let ((i 0))
  8777.                         (mapcap #'(lambda (dim)
  8778.                                     (prog1
  8779.                                       (if (eq dim '*)
  8780.                                         '()
  8781.                                         `((EQL ',dim (ARRAY-DIMENSION ,x ,i)))
  8782.                                       )
  8783.                                       (incf i)
  8784.                                   ) )
  8785.                                 dims
  8786.                       ) )
  8787.                    )
  8788.               ) )
  8789.        )
  8790. )   )
  8791. (defun c-typep-vector (tester)
  8792.   #'(lambda (x &optional (size '*) &rest illegal-args)
  8793.       (declare (ignore illegal-args))
  8794.       `(AND (,tester ,x)
  8795.             ,@(if (eq size '*)
  8796.                 '()
  8797.                 `((EQL (ARRAY-DIMENSION ,x 0) ',size))
  8798.               )
  8799.        )
  8800.     )
  8801. )
  8802. (defun c-typep-number (caller tester)
  8803.   #'(lambda (x &optional (low '*) (high '*) &rest illegal-args)
  8804.       (declare (ignore illegal-args))
  8805.       `(AND (,tester ,x)
  8806.             ,@(cond ((eq low '*) '())
  8807.                     ((funcall tester low) `((<= ,low ,x)))
  8808.                     ((and (consp low) (null (rest low)) (funcall tester (first low)))
  8809.                      `((< ,(first low) ,x))
  8810.                     )
  8811.                     (t (c-warn (DEUTSCH "~S: Argument zu ~S mu▀ *, ~S oder eine Liste von ~S sein: ~S"
  8812.                                 ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  8813.                                 FRANCAIS "~S : L'argument de ~S doit Ωtre *, ~S ou une liste de ~S: ~S")
  8814.                                'typep caller caller caller low
  8815.                        )
  8816.                        (throw 'c-TYPEP nil)
  8817.               )     )
  8818.             ,@(cond ((eq high '*) '())
  8819.                     ((funcall tester high) `((>= ,high ,x)))
  8820.                     ((and (consp high) (null (rest high)) (funcall tester (first high)))
  8821.                      `((> ,(first high) ,x))
  8822.                     )
  8823.                     (t (c-warn (DEUTSCH "~S: Argument zu ~S mu▀ *, ~S oder eine Liste von ~S sein: ~S"
  8824.                                 ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  8825.                                 FRANCAIS "~S : L'argument de ~S doit Ωtre *, ~S ou une liste de ~S: ~S")
  8826.                                'typep caller caller caller high
  8827.                        )
  8828.                        (throw 'c-TYPEP nil)
  8829.               )     )
  8830.        )
  8831.     )
  8832. )
  8833. (defconstant c-typep-alist3
  8834.   `((ARRAY . ,(c-typep-array 'ARRAYP))
  8835.     (SIMPLE-ARRAY . ,(c-typep-array 'SIMPLE-ARRAY-P))
  8836.     (VECTOR .
  8837.       ,#'(lambda (x &optional (el-type '*) (size '*) &rest illegal-args)
  8838.            (declare (ignore illegal-args))
  8839.            `(AND (VECTORP ,x)
  8840.                  ,@(if (eq el-type '*)
  8841.                      '()
  8842.                      `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
  8843.                    )
  8844.                  ,@(if (eq size '*)
  8845.                      '()
  8846.                      `((EQL (ARRAY-DIMENSION ,x 0) ',size))
  8847.                    )
  8848.             )
  8849.          )
  8850.     )
  8851.     (SIMPLE-VECTOR . ,(c-typep-vector 'SIMPLE-VECTOR-P))
  8852.     (COMPLEX .
  8853.       ,#'(lambda (x &optional (rtype '*) (itype rtype) &rest illegal-args)
  8854.            (declare (ignore illegal-args))
  8855.            `(AND (COMPLEXP ,x)
  8856.                  ,@(if (eq rtype '*)
  8857.                      '()
  8858.                      `((TYPEP (REALPART ,x) ',rtype))
  8859.                    )
  8860.                  ,@(if (eq itype '*)
  8861.                      '()
  8862.                      `((TYPEP (IMAGPART ,x) ',itype))
  8863.                    )
  8864.             )
  8865.          )
  8866.     )
  8867.     (INTEGER . ,(c-typep-number 'INTEGER 'INTEGERP))
  8868.     (MOD .
  8869.       ,#'(lambda (x &optional n &rest illegal-args)
  8870.            (declare (ignore illegal-args))
  8871.            (unless (integerp n)
  8872.              (c-warn (DEUTSCH "~S: Argument zu MOD mu▀ ganze Zahl sein: ~S"
  8873.                       ENGLISH "~S: argument to MOD must be an integer: ~S"
  8874.                       FRANCAIS "~S : L'argument de MOD doit Ωtre un entier: ~S")
  8875.                      'typep n
  8876.              )
  8877.              (throw 'c-TYPEP nil)
  8878.            )
  8879.            `(AND (INTEGERP ,x) (NOT (MINUSP ,x)) (< ,x ,n))
  8880.          )
  8881.     )
  8882.     (SIGNED-BYTE .
  8883.       ,#'(lambda (x &optional (n '*) &rest illegal-args)
  8884.            (declare (ignore illegal-args))
  8885.            (unless (or (eq n '*) (integerp n))
  8886.              (c-warn (DEUTSCH "~S: Argument zu SIGNED-BYTE mu▀ ganze Zahl oder * sein: ~S"
  8887.                       ENGLISH "~S: argument to SIGNED-BYTE must be an integer or * : ~S"
  8888.                       FRANCAIS "~S : L'argument de SIGNED-BYTE doit Ωtre un entier ou bien * : ~S")
  8889.                      'typep n
  8890.              )
  8891.              (throw 'c-TYPEP nil)
  8892.            )
  8893.            `(AND (INTEGERP ,x)
  8894.                  ,@(if (eq n '*) '() `((< (INTEGER-LENGTH ,x) ,n)))
  8895.             )
  8896.          )
  8897.     )
  8898.     (UNSIGNED-BYTE .
  8899.       ,#'(lambda (x &optional (n '*) &rest illegal-args)
  8900.            (declare (ignore illegal-args))
  8901.            (unless (or (eq n '*) (integerp n))
  8902.              (c-warn (DEUTSCH "~S: Argument zu UNSIGNED-BYTE mu▀ ganze Zahl oder * sein: ~S"
  8903.                       ENGLISH "~S: argument to UNSIGNED-BYTE must be an integer or * : ~S"
  8904.                       FRANCAIS "~S : L'argument de UNSIGNED-BYTE doit Ωtre un entier ou bien * : ~S")
  8905.                      'typep n
  8906.              )
  8907.              (throw 'c-TYPEP nil)
  8908.            )
  8909.            `(AND (INTEGERP ,x) (NOT (MINUSP ,x))
  8910.                  ,@(if (eq n '*) '() `((<= (INTEGER-LENGTH ,x) ,n)))
  8911.             )
  8912.          )
  8913.     )
  8914.     (REAL . ,(c-typep-number 'REAL 'REALP))
  8915.     (RATIONAL . ,(c-typep-number 'RATIONAL 'RATIONALP))
  8916.     (FLOAT . ,(c-typep-number 'FLOAT 'FLOATP))
  8917.     (SHORT-FLOAT . ,(c-typep-number 'SHORT-FLOAT 'SHORT-FLOAT-P))
  8918.     (SINGLE-FLOAT . ,(c-typep-number 'SINGLE-FLOAT 'SINGLE-FLOAT-P))
  8919.     (DOUBLE-FLOAT . ,(c-typep-number 'DOUBLE-FLOAT 'DOUBLE-FLOAT-P))
  8920.     (LONG-FLOAT . ,(c-typep-number 'LONG-FLOAT 'LONG-FLOAT-P))
  8921.     (STRING . ,(c-typep-vector 'STRINGP))
  8922.     (SIMPLE-STRING . ,(c-typep-vector 'SIMPLE-STRING-P))
  8923.     (BIT-VECTOR . ,(c-typep-vector 'BIT-VECTOR-P))
  8924.     (SIMPLE-BIT-VECTOR . ,(c-typep-vector 'SIMPLE-BIT-VECTOR-P))
  8925. )  )
  8926. (defun c-TYPEP () ; vgl. TYPEP in type.lsp
  8927.   (test-list *form* 3 3)
  8928.   (let ((objform (second *form*))
  8929.         (typeform (macroexpand-form (third *form*))))
  8930.     (when (c-constantp typeform)
  8931.       (let ((type (c-constant-value typeform)) h)
  8932.         (cond ((symbolp type)
  8933.                 (cond ; Test auf Property TYPE-SYMBOL:
  8934.                       ((setq h (assoc type c-typep-alist1))
  8935.                         (setq h (cdr h))
  8936.                         (return-from c-TYPEP
  8937.                           (c-GLOBAL-FUNCTION-CALL-form `(,h ,objform))
  8938.                       ) )
  8939.                       ((setq h (assoc type c-typep-alist2))
  8940.                         (setq h (cdr h))
  8941.                         (return-from c-TYPEP
  8942.                           (let ((*form* `(,h ,objform)))
  8943.                             (c-FUNCALL-INLINE
  8944.                               (symbol-suffix '#:TYPEP (symbol-name type))
  8945.                               (list objform)
  8946.                               nil
  8947.                               h
  8948.                               nil
  8949.                       ) ) ) )
  8950.                       ; Test auf Property TYPE-LIST:
  8951.                       ((setq h (assoc type c-typep-alist3))
  8952.                         (setq h (cdr h))
  8953.                         (let* ((objvar (gensym))
  8954.                                (testform (funcall h objvar))
  8955.                                (lambdabody `((,objvar) ,testform)))
  8956.                           (return-from c-TYPEP
  8957.                             (let ((*form* `((lambda ,@lambdabody) ,objform)))
  8958.                               (c-FUNCALL-INLINE
  8959.                                 (symbol-suffix '#:TYPEP (symbol-name type))
  8960.                                 (list objform)
  8961.                                 nil
  8962.                                 lambdabody
  8963.                                 nil
  8964.                       ) ) ) ) )
  8965.                       #+CLISP ; Test auf Property DEFTYPE-EXPANDER:
  8966.                       ((setq h (get type 'SYS::DEFTYPE-EXPANDER))
  8967.                         (return-from c-TYPEP
  8968.                           (c-form `(TYPEP ,objform ',(funcall h (list type))))
  8969.                       ) )
  8970.                       #+CLISP ; Test auf Property DEFSTRUCT-DESCRIPTION:
  8971.                       ((get type 'SYS::DEFSTRUCT-DESCRIPTION)
  8972.                         (return-from c-TYPEP
  8973.                           (c-form `(SYS::%STRUCTURE-TYPE-P ',type ,objform))
  8974.                       ) )
  8975.                       #+CLISP ; Test auf Property CLOS::CLASS:
  8976.                       ((and (setq h (get type 'CLOS::CLASS)) (clos::class-p h)
  8977.                             (eq (clos:class-name h) type)
  8978.                        )
  8979.                         (return-from c-TYPEP
  8980.                           (c-form `(CLOS::SUBCLASSP (CLOS:CLASS-OF ,objform)
  8981.                                      (LOAD-TIME-VALUE (CLOS:FIND-CLASS ',type))
  8982.                                    )
  8983.                       ) ) )
  8984.               ) )
  8985.               ((and (consp type) (symbolp (first type)))
  8986.                 (catch 'c-TYPEP
  8987.                   (cond ((and (eq (first type) 'SATISFIES) (eql (length type) 2))
  8988.                           (let ((fun (second type)))
  8989.                             (unless (symbolp (second type))
  8990.                               (c-warn (DEUTSCH "~S: Argument zu SATISFIES mu▀ Symbol sein: ~S"
  8991.                                        ENGLISH "~S: argument to SATISFIES must be a symbol: ~S"
  8992.                                        FRANCAIS "~S : L'argument de SATISFIES doit Ωtre un symbole: ~S")
  8993.                                       'typep (second type)
  8994.                               )
  8995.                               (throw 'c-TYPEP nil)
  8996.                             )
  8997.                             (return-from c-TYPEP
  8998.                               (c-GLOBAL-FUNCTION-CALL-form `(,fun ,objform))
  8999.                         ) ) )
  9000.                         ((eq (first type) 'MEMBER)
  9001.                           (return-from c-TYPEP
  9002.                             (let ((*form* `(CASE ,objform (,(rest type) T) (t NIL))))
  9003.                               (c-CASE)
  9004.                         ) ) )
  9005.                         ((and (eq (first type) 'EQL) (eql (length type) 2))
  9006.                           (return-from c-TYPEP
  9007.                             (let ((*form* `(EQL ,objform ',(second type))))
  9008.                               (c-EQL)
  9009.                         ) ) )
  9010.                         ((and (eq (first type) 'NOT) (eql (length type) 2))
  9011.                           (return-from c-TYPEP
  9012.                             (c-GLOBAL-FUNCTION-CALL-form
  9013.                               `(NOT (TYPEP ,objform ',(second type)))
  9014.                         ) ) )
  9015.                         ((or (eq (first type) 'AND) (eq (first type) 'OR))
  9016.                           (return-from c-TYPEP
  9017.                             (c-form
  9018.                               (let ((objvar (gensym)))
  9019.                                 `(LET ((,objvar ,objform))
  9020.                                    (,(first type) ; AND oder OR
  9021.                                     ,@(mapcar #'(lambda (typei) `(TYPEP ,objvar ',typei)) (rest type))
  9022.                                  ) )
  9023.                         ) ) ) )
  9024.                         ((setq h (assoc (first type) c-typep-alist3))
  9025.                           (setq h (cdr h))
  9026.                           (let* ((objvar (gensym))
  9027.                                  (testform (apply h objvar (rest type)))
  9028.                                  (lambdabody `((,objvar) ,testform)))
  9029.                             (return-from c-TYPEP
  9030.                               (let ((*form* `((lambda ,@lambdabody) ,objform)))
  9031.                                 (c-FUNCALL-INLINE
  9032.                                   (symbol-suffix '#:TYPEP (symbol-name (first type)))
  9033.                                   (list objform)
  9034.                                   nil
  9035.                                   lambdabody
  9036.                                   nil
  9037.                         ) ) ) ) )
  9038.               ) ) )
  9039.               ((and (clos::class-p type) (eq (get (clos:class-name type) 'CLOS::CLASS) type))
  9040.                 (return-from c-TYPEP
  9041.                   (c-form `(CLOS::SUBCLASSP (CLOS:CLASS-OF ,objform)
  9042.                              (LOAD-TIME-VALUE (CLOS:FIND-CLASS ',(clos:class-name type)))
  9043.                            )
  9044.               ) ) )
  9045.     ) ) )
  9046.     (c-GLOBAL-FUNCTION-CALL-form `(TYPEP ,objform ,typeform))
  9047. ) )
  9048.  
  9049. ;; c-FORMAT vgl. FORMAT in format.lsp
  9050. (defun c-FORMAT ()
  9051.   (test-list *form* 3)
  9052.   (if (stringp (third *form*))
  9053.     ; Format-String zur Compile-Zeit vorkompilieren.
  9054.     (c-GLOBAL-FUNCTION-CALL-form
  9055.       `(FORMAT ,(second *form*) (FORMATTER ,(third *form*)) ,@(cdddr *form*))
  9056.     )
  9057.     (c-GLOBAL-FUNCTION-CALL 'FORMAT)
  9058. ) )
  9059.  
  9060. ;; c-REMOVE-IF, c-REMOVE-IF-NOT usw.
  9061. (macrolet ((c-seqop (op n)
  9062.              (let ((op-if (intern (string-concat (string op) "-IF") *lisp-package*))
  9063.                    (op-if-not (intern (string-concat (string op) "-IF-NOT") *lisp-package*))
  9064.                    (c-op-if (intern (string-concat "C-" (string op) "-IF")))
  9065.                    (c-op-if-not (intern (string-concat "C-" (string op) "-IF-NOT"))))
  9066.                `(progn
  9067.                   (defun ,c-op-if ()
  9068.                     (test-list *form* ,(+ 1 n))
  9069.                     (let ((pred-arg (macroexpand-form
  9070.                                       ,(case n (2 `(second *form*))
  9071.                                                (3 `(third *form*))
  9072.                                        )
  9073.                          ))         )
  9074.                       (if (and (consp pred-arg) (eq (first pred-arg) 'COMPLEMENT)
  9075.                                (consp (rest pred-arg)) (null (cddr pred-arg))
  9076.                                ; (op-if (complement fn) ...) --> (op-if-not fn ...)
  9077.                                (not (fenv-search 'COMPLEMENT)) (not (declared-notinline 'COMPLEMENT))
  9078.                                (not (fenv-search 'NOT))
  9079.                           )
  9080.                         (c-form ,(case n (2 `(list* ',op-if-not (second pred-arg) (cddr *form*)))
  9081.                                          (3 `(list* ',op-if-not (second *form*) (second pred-arg) (cdddr *form*)))
  9082.                                  )
  9083.                         )
  9084.                         (c-GLOBAL-FUNCTION-CALL ',op-if)
  9085.                   ) ) )
  9086.                   (defun ,c-op-if-not ()
  9087.                     (test-list *form* ,(+ 1 n))
  9088.                     (let ((pred-arg (macroexpand-form
  9089.                                       ,(case n (2 `(second *form*))
  9090.                                                (3 `(third *form*))
  9091.                                        )
  9092.                          ))         )
  9093.                       (if (and (consp pred-arg) (eq (first pred-arg) 'COMPLEMENT)
  9094.                                (consp (rest pred-arg)) (null (cddr pred-arg))
  9095.                                ; (op-if-not (complement fn) ...) --> (op-if fn ...)
  9096.                                (not (fenv-search 'COMPLEMENT))
  9097.                                (not (fenv-search 'NOT))
  9098.                           )
  9099.                         (c-form ,(case n (2 `(list* ',op-if (second pred-arg) (cddr *form*)))
  9100.                                          (3 `(list* ',op-if (second *form*) (second pred-arg) (cdddr *form*)))
  9101.                                  )
  9102.                         )
  9103.                         (c-GLOBAL-FUNCTION-CALL ',op-if-not)
  9104.                   ) ) )
  9105.                )
  9106.           )) )
  9107.   (c-seqop REMOVE 2)
  9108.   (c-seqop DELETE 2)
  9109.   (c-seqop SUBSTITUTE 3)
  9110.   (c-seqop NSUBSTITUTE 3)
  9111.   (c-seqop FIND 2)
  9112.   (c-seqop POSITION 2)
  9113.   (c-seqop COUNT 2)
  9114.   (c-seqop SUBST 3)
  9115.   (c-seqop NSUBST 3)
  9116.   (c-seqop MEMBER 2)
  9117.   (c-seqop ASSOC 2)
  9118.   (c-seqop RASSOC 2)
  9119. )
  9120.  
  9121.  
  9122.  
  9123. ;                     Z W E I T E R   P A S S
  9124.  
  9125. ; eine Tabelle von Paaren (fnode n).
  9126. ; Jedes Paar zeigt an, da▀ im 3. Pass in der Konstanten Nummer n des
  9127. ; funktionalen Objektes von fnode der dort stehende fnode durch das durch ihn
  9128. ; erzeugte funktionale Objekt zu ersetzen ist.
  9129. (defvar *fnode-fixup-table*)
  9130.  
  9131. ; macht aus dem ANODE-Baum zum fnode *func* ein funktionales Objekt:
  9132. (defun pass2 (*func*)
  9133.   (when (anode-p (fnode-code *func*)) ; falls 2. Pass noch nicht durchgefⁿhrt:
  9134.     ; erst den Code flachklopfen, optimieren und assemblieren:
  9135.     (let ((code-list (compile-to-LAP))) ; Code flachklopfen und in Stⁿcke zerteilen,
  9136.                                         ; optimieren und zu einer Liste machen
  9137.       (when (fnode-gf-p *func*) (setq code-list (CONST-to-LOADV code-list))) ; evtl. CONSTs umwandeln
  9138.       (let ((SPdepth (SP-depth code-list))) ; Stackbedarf bestimmen
  9139.         (setq code-list (insert-combined-LAPs code-list)) ; kombinierte Operationen einfⁿhren
  9140.         (create-fun-obj *func* (assemble-LAP code-list) SPdepth) ; assemblieren und funkt. Objekt
  9141.     ) )
  9142.     ; dann die Sub-Funktionen durch den 2. Pass jagen
  9143.     (dolist (x (fnode-Consts *func*)) (if (fnode-p x) (pass2 x)))
  9144. ) )
  9145.  
  9146. #|
  9147.  
  9148. pass2 ruft den 1. Schritt auf.
  9149.  
  9150. Nach dem 1. Schritt ist der Code in kleine Stⁿcke aufgeteilt, jeweils von
  9151. einem Label bis zu einem Wegsprung (JMP, JMPCASE, JMPCASE1-TRUE, JMPCASE1-FALSE,
  9152. JMPHASH, RETURN-FROM, GO, RET, THROW, BARRIER). Die Teile stecken (jeweils als
  9153. Liste in umgekehrter Reihenfolge, mit dem Label als letztem CDR) im Vektor
  9154. *code-parts*.
  9155. (symbol-value label) enthΣlt eine Liste der Referenzen von label, und zwar in
  9156. der Form:
  9157.  - Index in *code-parts*, wenn die Referenz der entsprechende Wegsprung ist;
  9158.  - opcode sonst, wobei opcode der Befehl ist, in dem label auftritt.
  9159. Nach dem 1. Schritt enthΣlt der Code nur noch Tags (Symbole) und Listen aus
  9160. Symbolen und Zahlen. Es darf daher mit SUBST und EQUAL gearbeitet werden.
  9161.  
  9162. Der 1. Schritt ruft, sobald er mit einem Stⁿck fertig ist, den 2. Schritt
  9163. auf.
  9164.  
  9165. Dann ruft pass2 den 3. Schritt auf. Es handelt sich hier um Optimierungen,
  9166. die, wenn sie erfolgreich waren, weitere dieser Optimierungen aufrufen.
  9167.  
  9168. |#
  9169.  
  9170. #|
  9171.                              1. Schritt:
  9172.           Expansion von Code-Teilen, Aufteilen des Codes in Stⁿcke
  9173.  
  9174. VerΣndert werden:
  9175.  
  9176. vorher                           nachher
  9177.  
  9178. (CONST const)                    (CONST n const)
  9179. (FCONST fnode)                   (CONST n), Fixup fⁿr 3. Pass merken
  9180. (BCONST block)                   (CONST n)
  9181. (GCONST tagbody)                 (CONST n)
  9182. (GET var venvc stackz)           (LOAD n) oder (LOADI k1 k2 n)
  9183.                                  oder (LOADC n m) oder (LOADIC k1 k2 n m)
  9184.                                  oder (LOADV k m) oder (GETVALUE n)
  9185.                                  oder (CONST n) oder (CONST n const)
  9186. (SET var venvc stackz)           (STORE n) oder (STOREI k1 k2 n)
  9187.                                  oder (STOREC n m) oder (STOREIC k1 k2 n m)
  9188.                                  oder (STOREV k m) oder (SETVALUE n)
  9189. (SETVALUE symbol)                (SETVALUE n)
  9190. (GETVALUE symbol)                (GETVALUE n)
  9191. (BIND const)                     (BIND n)
  9192. (UNWIND stackz1 stackz2 for-value) eine Folge von
  9193.                                  (SKIP n), (SKIPI k1 k2 n), (SKIPSP k1 k2),
  9194.                                  (VALUES0), (UNWIND-PROTECT-CLEANUP), (UNBIND1),
  9195.                                  (BLOCK-CLOSE), (TAGBODY-CLOSE)
  9196. (UNWINDSP stackz1 stackz2)       eine Folge von (SKIPSP k1 k2)
  9197. (JMPIF label)                    (JMPCASE label new-label) new-label
  9198. (JMPIFNOT label)                 (JMPCASE new-label label) new-label
  9199. (JMPIF1 label)                   (JMPCASE1-TRUE label new-label) new-label
  9200. (JMPIFNOT1 label)                (JMPCASE1-FALSE new-label label) new-label
  9201. (JMPHASH test ((obj1 . label1) ... (objm . labelm)) label . labels)
  9202.                                  (JMPHASH n ht label . labels)
  9203.                                  wobei ht = Hash-Tabelle (obji -> labeli) ist
  9204. (VENV venvc stackz)              (VENV) oder (NIL)
  9205.                                  oder (LOAD n) oder (LOADI k1 k2 n)
  9206. (COPY-CLOSURE fnode n)           (COPY-CLOSURE m n), Fixup fⁿr 3. Pass merken
  9207. (CALLP)                          gestrichen
  9208. (CALL k fun)                     (CALL k n)
  9209. (CALL0 fun)                      (CALL0 n)
  9210. (CALL1 fun)                      (CALL1 n)
  9211. (CALL2 fun)                      (CALL2 n)
  9212. (FUNCALLP)                       (PUSH)
  9213. (APPLYP)                         (PUSH)
  9214. (JMPIFBOUNDP var venvc stackz label)
  9215.                                  (JMPIFBOUNDP n label)
  9216. (BOUNDP var venvc stackz)        (BOUNDP n)
  9217. (BLOCK-OPEN const label)         (BLOCK-OPEN n label)
  9218. (RETURN-FROM const)              (RETURN-FROM n)
  9219. (RETURN-FROM block)              (RETURN-FROM n)
  9220. (RETURN-FROM block stackz)       (RETURN-FROM-I k1 k2 n)
  9221. (TAGBODY-OPEN const label1 ... labelm)
  9222.                                  (TAGBODY-OPEN n label1 ... labelm)
  9223. (GO const l)                     (GO n l)
  9224. (GO tagbody l)                   (GO n l)
  9225. (GO tagbody l stackz)            (GO-I k1 k2 n l)
  9226. (HANDLER-OPEN const stackz label1 ... labelm)
  9227.                                  (HANDLER-OPEN n v k label1 ... labelm)
  9228.  
  9229.  
  9230. unverΣndert bleiben:
  9231. (NIL)
  9232. (PUSH-NIL n)
  9233. (T)
  9234. (STORE n)
  9235. (UNBIND1)
  9236. (PROGV)
  9237. (PUSH)
  9238. (POP)
  9239. (RET)
  9240. (JMP label)
  9241. (JSR m label)
  9242. (BARRIER)
  9243. (MAKE-VECTOR1&PUSH n)
  9244. (CALLS1 n)
  9245. (CALLS2 n)
  9246. (CALLSR m n)
  9247. (CALLC)
  9248. (CALLCKEY)
  9249. (FUNCALL n)
  9250. (APPLY n)
  9251. (PUSH-UNBOUND n)
  9252. (UNLIST n m)
  9253. (UNLIST* n m)
  9254. (VALUES0)
  9255. (VALUES1)
  9256. (STACK-TO-MV n)
  9257. (MV-TO-STACK)
  9258. (NV-TO-STACK n)
  9259. (MV-TO-LIST)
  9260. (LIST-TO-MV)
  9261. (MVCALLP)
  9262. (MVCALL)
  9263. (BLOCK-CLOSE)
  9264. (TAGBODY-CLOSE-NIL)
  9265. (TAGBODY-CLOSE)
  9266. (CATCH-OPEN label)
  9267. (CATCH-CLOSE)
  9268. (THROW)
  9269. (UNWIND-PROTECT-OPEN label)
  9270. (UNWIND-PROTECT-NORMAL-EXIT)
  9271. (UNWIND-PROTECT-CLOSE label)
  9272. (UNWIND-PROTECT-CLEANUP)
  9273. (HANDLER-BEGIN)
  9274. (NOT)
  9275. (EQ)
  9276. (CAR)
  9277. (CDR)
  9278. (CONS)
  9279. (ATOM)
  9280. (CONSP)
  9281. (SYMBOL-FUNCTION)
  9282. (SVREF)
  9283. (SVSET)
  9284. (LIST n)
  9285. (LIST* n)
  9286.  
  9287. Neue Operationen:
  9288.  
  9289. (JMP label boolvalue)            Sprung zu label, boolvalue beschreibt den 1.
  9290.                                  Wert: FALSE falls =NIL, TRUE falls /=NIL,
  9291.                                  NIL falls unbekannt.
  9292.  
  9293. (JMPCASE label1 label2)          Sprung zu label1, falls A0 /= NIL,
  9294.                                  bzw. zu label2, falls A0 = NIL.
  9295.  
  9296. (JMPCASE1-TRUE label1 label2)    Falls A0 /= NIL: Sprung nach label1, 1 Wert.
  9297.                                  Falls A0 = NIL: Sprung nach label2.
  9298.  
  9299. (JMPCASE1-FALSE label1 label2)   Falls A0 /= NIL: Sprung nach label1.
  9300.                                  Falls A0 = NIL: Sprung nach label2, 1 Wert.
  9301.  
  9302. (JMPTAIL m n label)              Verkleinerung des Stack-Frames von n auf m,
  9303.                                  dann Sprung zu label mit undefinierten Werten.
  9304.  
  9305. |#
  9306.  
  9307. ; Ein Vektor mit Fill-Pointer, der die Codestⁿcke enthΣlt:
  9308. (defvar *code-parts*)
  9309.  
  9310. ; Ein gleichlanger Vektor mit Fill-Pointer, der zu jedem Codestⁿck eine
  9311. ; "Position" enthΣlt, wo das Stⁿck am Ende landen soll (0 = ganz am Anfang,
  9312. ; je h÷her, desto weiter hinten).
  9313. (defvar *code-positions*)
  9314.  
  9315. ; TrΣgt eine Konstante in (fnode-consts *func*) ein und liefert deren Index n.
  9316. ; value ist der Wert der Konstanten,
  9317. ; form eine Form mit diesem Wert oder NIL,
  9318. ; horizont = :value (dann ist form = NIL) oder :all oder :form.
  9319. (defun value-form-index (value form horizont &optional (func *func*))
  9320.   (let ((const-list (fnode-consts func))
  9321.         (forms-list (fnode-consts-forms func))
  9322.         (n (fnode-Consts-Offset func)))
  9323.     (if (null const-list)
  9324.       (progn
  9325.         (setf (fnode-consts func) (list value))
  9326.         (setf (fnode-consts-forms func) (list form))
  9327.         n
  9328.       )
  9329.       (loop
  9330.         (when (if (eq horizont ':form)
  9331.                 (eql (car forms-list) form)
  9332.                 ; Bei horizont = :value oder :all vergleichen wir nur value.
  9333.                 (eql (car const-list) value)
  9334.               )
  9335.           (return n)
  9336.         )
  9337.         (incf n)
  9338.         (when (null (cdr const-list))
  9339.           (setf (cdr const-list) (list value))
  9340.           (setf (cdr forms-list) (list form))
  9341.           (return n)
  9342.         )
  9343.         (setq const-list (cdr const-list))
  9344.         (setq forms-list (cdr forms-list))
  9345. ) ) ) )
  9346. (defun constvalue-index (value)
  9347.   (value-form-index value nil ':value)
  9348. )
  9349.  
  9350. ; sucht eine Konstante in (fnode-Keywords *func*) und in (fnode-Consts *func*),
  9351. ; trΣgt sie eventuell in (fnode-Consts *func*) ein. Liefert ihren Index n.
  9352. (defun kvalue-form-index (value form horizont &optional (func *func*))
  9353.   (when (and (not (eq horizont ':form)) (keywordp value)) ; nur bei Keywords lohnt sich die Suche
  9354.     (do ((n (fnode-Keyword-Offset func) (1+ n))
  9355.          (L (fnode-Keywords func) (cdr L)))
  9356.         ((null L))
  9357.       (if (eq (car L) value) (return-from kvalue-form-index n))
  9358.   ) )
  9359.   (value-form-index value form horizont func)
  9360. )
  9361. (defun kconstvalue-index (value)
  9362.   (kvalue-form-index value nil ':value)
  9363. )
  9364. (defun const-index (const)
  9365.   (if (and *compiling-from-file* (not (eq (const-horizont const) ':value)))
  9366.     (kvalue-form-index (const-value const) (const-form const) (const-horizont const))
  9367.     (kvalue-form-index (const-value const) nil ':value)
  9368. ) )
  9369.  
  9370. ; (make-const-code const) liefert den Code, der den Wert der Konstanten
  9371. ; als 1 Wert nach A0 bringt.
  9372. (defun make-const-code (const)
  9373.   (unless (eq (const-horizont const) ':form)
  9374.     (let ((value (const-value const)))
  9375.       (cond ((eq value 'nil) (return-from make-const-code '(NIL) ))
  9376.             ((eq value 't) (return-from make-const-code '(T) ))
  9377.   ) ) )
  9378.   `(CONST ,(const-index const) ,const)
  9379. )
  9380.  
  9381. ; (bconst-index block) liefert den Index in FUNC, an dem dieser Block steht.
  9382. (defun bconst-index (block &optional (func *func*))
  9383. ; (+ (fnode-Blocks-Offset func)
  9384. ;    (position block (fnode-Blocks func) :test #'eq)
  9385. ; )
  9386.   (do ((n (fnode-Blocks-Offset func) (1+ n))
  9387.        (L (fnode-Blocks func) (cdr L)))
  9388.       ((eq (car L) block) n)
  9389. ) )
  9390.  
  9391. ; (gconst-index tagbody) liefert den Index in FUNC, an dem dieser Tagbody steht.
  9392. (defun gconst-index (tagbody &optional (func *func*))
  9393. ; (+ (fnode-Tagbodys-Offset func)
  9394. ;    (position tagbody (fnode-Tagbodys func) :test #'eq)
  9395. ; )
  9396.   (do ((n (fnode-Tagbodys-Offset func) (1+ n))
  9397.        (L (fnode-Tagbodys func) (cdr L)))
  9398.       ((eq (car L) tagbody) n)
  9399. ) )
  9400.  
  9401. ; (fconst-index fnode) liefert den Index in FUNC, an dem dieser fnode in den
  9402. ; Konstanten steht. Wenn n÷tig, wird er eingefⁿgt und in *fnode-fixup-table*
  9403. ; vermerkt.
  9404. (defun fconst-index (fnode &optional (func *func*))
  9405.   (if (member fnode (fnode-Consts func))
  9406.     (constvalue-index fnode)
  9407.     (let ((n (constvalue-index fnode)))
  9408.       (push (list func n) *fnode-fixup-table*)
  9409.       n
  9410. ) ) )
  9411.  
  9412. ; Hilfsvariablen beim rekursiven Aufruf von traverse-anode:
  9413.  
  9414. ; Das aktuelle Codestⁿck, eine umgedrehte Liste von Instruktionen, die
  9415. ; mit dem Start-Label als letztem nthcdr endet.
  9416. (defvar *code-part*)
  9417.  
  9418. ; und seine Nummer (Index in *code-parts*)
  9419. (defvar *code-index*)
  9420.  
  9421. ; Flag, ob "toter Code" (d.h. Code, der nicht erreichbar ist) vorliegt
  9422. (defvar *dead-code*)
  9423.  
  9424. ; Fⁿr Sprungkettenverkⁿrzung in traverse-anode: Liste aller bereits
  9425. ; durchgefⁿhrten Label-Substitutionen ((old-label . new-label) ...)
  9426. (defvar *label-subst*)
  9427.  
  9428. ; Der aktuelle Wert, interpretiert als boolescher Wert:
  9429. ; FALSE falls =NIL, TRUE falls /=NIL, NIL falls unbekannt.
  9430. ; (Keine EinschrΣnkung an die Anzahl der Werte!)
  9431. (defvar *current-value*)
  9432.  
  9433. ; Liste der Variablen/Konstanten, deren Wert mit dem aktuellen ⁿbereinstimmt
  9434. ; (lexikalische Variablen als VARIABLE-Structures, dynamische Variablen als
  9435. ; Symbole, Konstanten als CONST-Structures mit horizont = :value oder :all).
  9436. ; Ist diese Liste nichtleer, so liegt auch genau 1 Wert vor.
  9437. (defvar *current-vars*)
  9438.  
  9439. ; Jedes Label (ein Gensym-Symbol) hat als Wert eine Liste aller Referenzen
  9440. ; auf label, und zwar jeweils entweder als Index i in *code-parts*, wenn es
  9441. ; sich um den Wegsprung (das Ende) von (aref *code-parts* i) handelt, oder
  9442. ; als Instruktion (einer Liste) in allen anderen FΣllen. Falls das Label
  9443. ; ein Codestⁿck beginnt, steht unter (get label 'code-part) der Index in
  9444. ; *code-part* des Codestⁿcks, das mit diesem Label anfΣngt. Unter
  9445. ; (get label 'for-value) steht, wieviele Werte bei einem m÷glichen Sprung
  9446. ; auf das Label von Bedeutung sind (NIL/ONE/ALL).
  9447. ; Eine Ausnahme stellt das "Label" NIL dar, das den Einsprungpunkt darstellt.
  9448.  
  9449. ; Ersetzt alle Referenzen auf old-label durch Referenzen auf new-label.
  9450. (defun label-subst (old-label new-label)
  9451.   ; alle Referenzen auf old-label verΣndern:
  9452.   (dolist (ref (symbol-value old-label))
  9453.     (nsubst new-label old-label
  9454.             (rest (if (integerp ref) (first (aref *code-parts* ref)) ref))
  9455.   ) )
  9456.   ; und als Referenzen auf new-label eintragen:
  9457.   (setf (symbol-value new-label)
  9458.     (nconc (symbol-value old-label) (symbol-value new-label))
  9459.   )
  9460.   (setf (symbol-value old-label) '())
  9461.   ; Mit old-label fΣngt kein Codestⁿck mehr an:
  9462.   (remprop old-label 'code-part)
  9463. )
  9464.  
  9465. ; Aktuelles Codestⁿck beenden und ein neues Codestⁿck anfangen:
  9466. (defun finish-code-part ()
  9467.   ; das aktuelle Codestⁿck vereinfachen:
  9468.   (simplify *code-part*)
  9469.   ; *code-part* in *code-parts* unterbringen:
  9470.   (vector-push-extend *code-part* *code-parts*)
  9471.   (vector-push-extend (incf *code-index*) *code-positions*)
  9472. )
  9473.  
  9474. ; Einen Wegsprung auf Label label emittieren.
  9475. ; Dadurch wird ein neues Codestⁿck angefangen.
  9476. (defun emit-jmp (label)
  9477.   ; mit einem Wegsprung:
  9478.   (push `(JMP ,label ,*current-value*) *code-part*)
  9479.   (push *code-index* (symbol-value label))
  9480.   (finish-code-part)
  9481. )
  9482.  
  9483. ; LΣuft durch den Code eines Anode durch, expandiert den Code und baut dabei
  9484. ; *code-part* weiter. Adjustiert die Variablen *current-value* usw. passend.
  9485. (defun traverse-anode (code)
  9486.   (dolist (item code)
  9487.     (if (atom item)
  9488.       (cond ((symbolp item) ; Label
  9489.              (if *dead-code*
  9490.                ; Code kann angesprungen werden, ist ab jetzt nicht mehr tot
  9491.                (setq *dead-code* nil)
  9492.                (if (symbolp *code-part*)
  9493.                  ; Label item sofort nach Label *code-part*
  9494.                  ; -> k÷nnen identifiziert werden
  9495.                  (let ((old-label *code-part*) (new-label item))
  9496.                    ; substituiere *code-parts* -> item
  9497.                    (label-subst old-label new-label)
  9498.                    (setq *label-subst*
  9499.                      (acons old-label new-label
  9500.                        (nsubst new-label old-label *label-subst*)
  9501.                  ) ) )
  9502.                  ; Label mitten im Codestⁿck -> aktuelles Codestⁿck beenden
  9503.                  (emit-jmp item)
  9504.              ) )
  9505.              ; jetzt geht das aktuelle Codestⁿck erst richtig los,
  9506.              ; mit dem Label item:
  9507.              (setq *code-part* item)
  9508.              (setf (get item 'code-part) (fill-pointer *code-parts*))
  9509.              ; Da noch Sprⁿnge auf dieses Label kommen k÷nnen, wissen wir
  9510.              ; nicht, was A0 enthΣlt:
  9511.              (setq *current-value* nil *current-vars* '())
  9512.             )
  9513.             ((anode-p item) (traverse-anode (anode-code item))) ; Anode -> rekursiv
  9514.             (t (compiler-error 'traverse-anode "ITEM"))
  9515.       )
  9516.       ; item ist eine normale Instruktion
  9517.       (unless *dead-code* ; nur erreichbarer Code braucht verarbeitet zu werden
  9518.         (nsublis *label-subst* (rest item)) ; bisherige Substitutionen durchfⁿhren
  9519.         (case (first item)
  9520.           (CONST
  9521.             (let ((const (second item)))
  9522.               (if (eq (const-horizont const) ':form)
  9523.                 (progn
  9524.                   (push (make-const-code const) *code-part*)
  9525.                   (setq *current-value* nil *current-vars* '())
  9526.                 )
  9527.                 (let ((cv (const-value const)))
  9528.                   (unless ; ein (CONST cv) schon in *current-vars* enthalten?
  9529.                       (dolist (v *current-vars* nil)
  9530.                         (when (and (const-p v) (eq (const-value v) cv)) (return t))
  9531.                       )
  9532.                     (push (make-const-code const) *code-part*)
  9533.                     (setq *current-value* (if (null cv) 'FALSE 'TRUE)
  9534.                           *current-vars* (list const)
  9535.           ) ) ) ) ) )
  9536.           (FCONST
  9537.             (push `(CONST ,(fconst-index (second item))) *code-part*)
  9538.             (setq *current-value* 'TRUE *current-vars* '())
  9539.           )
  9540.           (BCONST
  9541.             (push `(CONST ,(bconst-index (second item))) *code-part*)
  9542.             (setq *current-value* 'TRUE *current-vars* '())
  9543.           )
  9544.           (GCONST
  9545.             (push `(CONST ,(gconst-index (second item))) *code-part*)
  9546.             (setq *current-value* 'TRUE *current-vars* '())
  9547.           )
  9548.           (GET
  9549.             (let ((var (second item))
  9550.                   (venvc (third item))
  9551.                   (stackz (fourth item)))
  9552.               (unless (member var *current-vars* :test #'eq) ; Ist bereits der aktuelle Wert = var ?
  9553.                 (push
  9554.                   (if (var-constantp var)
  9555.                     (let* ((const (var-constant var))
  9556.                            (val (const-value const)))
  9557.                       (setq *current-value* (if (null val) 'FALSE 'TRUE))
  9558.                       (if (fnode-p val)
  9559.                         ; FNODEs als Werte k÷nnen (fast) nur von LABELS stammen
  9560.                         `(CONST ,(fconst-index val))
  9561.                         (make-const-code const)
  9562.                     ) )
  9563.                     (progn
  9564.                       (setq *current-value* nil)
  9565.                       (if (var-specialp var)
  9566.                         `(GETVALUE ,(kconstvalue-index (setq var (var-name var))))
  9567.                         (if (var-closurep var)
  9568.                           (multiple-value-bind (k n m)
  9569.                               (zugriff-in-closure var venvc stackz)
  9570.                             (if n
  9571.                               (if k `(LOADIC ,(car k) ,(cdr k) ,n ,m) `(LOADC ,n ,m))
  9572.                               `(LOADV ,k ,(1+ m))
  9573.                           ) )
  9574.                           ; lexikalisch und im Stack, also in derselben Funktion
  9575.                           (multiple-value-bind (k n)
  9576.                               (zugriff-in-stack stackz (var-stackz var))
  9577.                             (if k `(LOADI ,(car k) ,(cdr k) ,n) `(LOAD ,n) )
  9578.                   ) ) ) ) )
  9579.                   *code-part*
  9580.                 )
  9581.                 (setq *current-vars* (list var))
  9582.           ) ) )
  9583.           (SET
  9584.             (let ((var (second item))
  9585.                   (venvc (third item))
  9586.                   (stackz (fourth item)))
  9587.               (unless (member var *current-vars* :test #'eq) ; Ist bereits der aktuelle Wert = var ?
  9588.                 (push
  9589.                   (if (var-specialp var)
  9590.                     `(SETVALUE ,(kconstvalue-index (setq var (var-name var))))
  9591.                     (if (var-closurep var)
  9592.                       (multiple-value-bind (k n m)
  9593.                           (zugriff-in-closure var venvc stackz)
  9594.                         (if n
  9595.                           (if k `(STOREIC ,(car k) ,(cdr k) ,n ,m) `(STOREC ,n ,m))
  9596.                           `(STOREV ,k ,(1+ m))
  9597.                       ) )
  9598.                       ; lexikalisch und im Stack, also in derselben Funktion
  9599.                       (multiple-value-bind (k n)
  9600.                           (zugriff-in-stack stackz (var-stackz var))
  9601.                         (if k `(STOREI ,(car k) ,(cdr k) ,n) `(STORE ,n) )
  9602.                   ) ) )
  9603.                   *code-part*
  9604.                 )
  9605.                 (push var *current-vars*) ; *current-value* bleibt unverΣndert
  9606.           ) ) )
  9607.           (GETVALUE
  9608.             (let ((symbol (second item)))
  9609.               (unless (member symbol *current-vars* :test #'eq)
  9610.                 (push `(GETVALUE ,(kconstvalue-index symbol)) *code-part*)
  9611.                 (setq *current-value* nil *current-vars* (list symbol))
  9612.           ) ) )
  9613.           (SETVALUE
  9614.             (let ((symbol (second item)))
  9615.               (unless (member symbol *current-vars* :test #'eq)
  9616.                 (push `(SETVALUE ,(kconstvalue-index symbol)) *code-part*)
  9617.                 (push symbol *current-vars*) ; *current-value* bleibt unverΣndert
  9618.           ) ) )
  9619.           (BIND
  9620.             (push `(BIND ,(const-index (second item))) *code-part*)
  9621.             (setq *current-value* nil *current-vars* '()) ; undefinierte Werte
  9622.           )
  9623.           (UNWIND ; mehrzeilige Umwandlung
  9624.             (traverse-anode
  9625.               (expand-UNWIND (second item) (third item) (fourth item))
  9626.           ) )
  9627.           (UNWINDSP ; mehrzeilige Umwandlung
  9628.             (let ((k (spdepth-difference (second item) (third item))))
  9629.               (when (or (> (car k) 0) (> (cdr k) 0))
  9630.                 (push `(SKIPSP ,(car k) ,(cdr k)) *code-part*)
  9631.           ) ) )
  9632.           ((JMPIF JMPIFNOT JMPIF1 JMPIFNOT1)
  9633.             (if (null *current-value*)
  9634.               (let ((label (second item))
  9635.                     (new-label (make-label 'NIL)))
  9636.                 (push
  9637.                   (case (first item)
  9638.                     (JMPIF `(JMPCASE ,label ,new-label))
  9639.                     (JMPIFNOT `(JMPCASE ,new-label ,label))
  9640.                     (JMPIF1 `(JMPCASE1-TRUE ,label ,new-label))
  9641.                     (JMPIFNOT1 `(JMPCASE1-FALSE ,new-label ,label))
  9642.                   )
  9643.                   *code-part*
  9644.                 )
  9645.                 (push *code-index* (symbol-value (second item)))
  9646.                 (push *code-index* (symbol-value new-label))
  9647.                 (finish-code-part)
  9648.                 (setf (get new-label 'code-part) (fill-pointer *code-parts*))
  9649.                 (setq *code-part* new-label)
  9650.                 ; *current-value* und *current-vars* bleiben unverΣndert.
  9651.               )
  9652.               ; boolescher Wert beim Wegsprung bekannt
  9653.               (if (if (eq *current-value* 'FALSE)
  9654.                     (memq (first item) '(JMPIF JMPIF1)) ; Wert=NIL -> JMPIF weglassen
  9655.                     (memq (first item) '(JMPIFNOT JMPIFNOT1)) ; Wert/=NIL -> JMPIFNOT weglassen
  9656.                   )
  9657.                 ; Sprung weglassen
  9658.                 nil
  9659.                 ; in JMP umwandeln:
  9660.                 (progn
  9661.                   (when (memq (first item) '(JMPIF1 JMPIFNOT1))
  9662.                     (push '(VALUES1) *code-part*) ; genau 1 Wert erzwingen
  9663.                   )
  9664.                   (emit-jmp (second item))
  9665.                   (setq *dead-code* t)
  9666.           ) ) ) )
  9667.           (JMPHASH
  9668.             (let ((hashtable (make-hash-table :test (second item)))
  9669.                   (labels (cddddr item)))
  9670.               (dolist (acons (third item))
  9671.                 (setf (gethash (car acons) hashtable)
  9672.                       (position (cdr acons) labels)
  9673.               ) )
  9674.               (push `(JMPHASH ,(constvalue-index hashtable) ,hashtable
  9675.                               ,@(cdddr item)
  9676.                      )
  9677.                     *code-part*
  9678.             ) )
  9679.             ; Referenzen vermerken:
  9680.             (dolist (label (cdddr item))
  9681.               (push *code-index* (symbol-value label))
  9682.             )
  9683.             (finish-code-part)
  9684.             (setq *dead-code* t)
  9685.           )
  9686.           (VENV
  9687.             (let ((venvc (second item))
  9688.                   (stackz (third item)))
  9689.               (loop ; in venvc die NILs ⁿbergehen
  9690.                 (when (car venvc) (return))
  9691.                 (setq venvc (cdr venvc))
  9692.               )
  9693.               (push
  9694.                 (if (consp (car venvc)) ; aus dem Stack holen
  9695.                   (multiple-value-bind (k n)
  9696.                       (zugriff-in-stack stackz (cdr (car venvc)))
  9697.                     (if k `(LOADI ,(car k) ,(cdr k) ,n) `(LOAD ,n) )
  9698.                   )
  9699.                   (if (eq (car venvc) *func*)
  9700.                     (if (fnode-Venvconst *func*) '(VENV) '(NIL))
  9701.                     (compiler-error 'traverse-anode 'VENV)
  9702.                 ) )
  9703.                 *code-part*
  9704.               )
  9705.               (if (equal (car *code-part*) '(NIL))
  9706.                 (setq *current-value* 'FALSE *current-vars* (list (make-const :horizont ':value :value 'NIL)))
  9707.                 (setq *current-value* nil *current-vars* '())
  9708.               )
  9709.           ) )
  9710.           (COPY-CLOSURE
  9711.             (push `(COPY-CLOSURE ,(fconst-index (second item)) ,(third item))
  9712.                    *code-part*
  9713.             )
  9714.             (setq *current-value* 'TRUE *current-vars* '())
  9715.           )
  9716.           (CALLP) ; wird gestrichen
  9717.           (CALL
  9718.             (push `(CALL ,(second item) ,(const-index (third item)))
  9719.                    *code-part*
  9720.             )
  9721.             (setq *current-value* nil *current-vars* '())
  9722.           )
  9723.           ((CALL0 CALL1 CALL2)
  9724.             (push `(,(first item) ,(const-index (second item)))
  9725.                   *code-part*
  9726.             )
  9727.             (setq *current-value* nil *current-vars* '())
  9728.           )
  9729.           ((FUNCALLP APPLYP)
  9730.             (push '(PUSH) *code-part*)
  9731.             (setq *current-value* nil *current-vars* '())
  9732.           )
  9733.           ((JMPIFBOUNDP BOUNDP)
  9734.             (let ((var (second item))
  9735.                   (stackz (fourth item))
  9736.                  )
  9737.               (when (var-closurep var)
  9738.                 (compiler-error 'traverse-anode 'var-closurep)
  9739.               )
  9740.               (multiple-value-bind (k n)
  9741.                   (zugriff-in-stack stackz (var-stackz var))
  9742.                 (when k (compiler-error 'traverse-anode 'var-stackz))
  9743.                 (push `(,(first item) ,n ,@(cddddr item)) *code-part*)
  9744.                 (when (eq (first item) 'JMPIFBOUNDP)
  9745.                   (push (first *code-part*) (symbol-value (fifth item)))
  9746.                 )
  9747.                 (setq *current-value* nil *current-vars* '()) ; undefinierte Werte
  9748.           ) ) )
  9749.           (BLOCK-OPEN
  9750.             (let ((label (third item)))
  9751.               (push `(BLOCK-OPEN ,(const-index (second item)) ,label)
  9752.                      *code-part*
  9753.               )
  9754.               (push (first *code-part*) (symbol-value label))
  9755.           ) )
  9756.           (RETURN-FROM
  9757.             (push
  9758.               (if (cddr item)
  9759.                 (multiple-value-bind (k n)
  9760.                     (zugriff-in-stack (third item) (block-stackz (second item)))
  9761.                   `(RETURN-FROM-I ,(car k) ,(cdr k) ,n)
  9762.                 )
  9763.                 (if (block-p (second item))
  9764.                   `(RETURN-FROM ,(bconst-index (second item)))
  9765.                   `(RETURN-FROM ,(const-index (second item)))
  9766.               ) )
  9767.               *code-part*
  9768.             )
  9769.             (finish-code-part)
  9770.             (setq *dead-code* t)
  9771.           )
  9772.           (TAGBODY-OPEN
  9773.             (push `(TAGBODY-OPEN ,(const-index (second item)) ,@(cddr item))
  9774.                   *code-part*
  9775.             )
  9776.             (dolist (label (cddr item)) (push item (symbol-value label)))
  9777.           )
  9778.           (GO
  9779.             (push
  9780.               (if (cdddr item)
  9781.                 (multiple-value-bind (k n)
  9782.                     (zugriff-in-stack (fourth item) (tagbody-stackz (second item)))
  9783.                   `(GO-I ,(car k) ,(cdr k) ,n ,(third item))
  9784.                 )
  9785.                 (if (tagbody-p (second item))
  9786.                   `(GO ,(gconst-index (second item)) ,(third item))
  9787.                   `(GO ,(const-index (second item)) ,(third item))
  9788.               ) )
  9789.               *code-part*
  9790.             )
  9791.             (finish-code-part)
  9792.             (setq *dead-code* t)
  9793.           )
  9794.           ((NIL TAGBODY-CLOSE-NIL)
  9795.             (push item *code-part*)
  9796.             (setq *current-value* 'FALSE *current-vars* (list (make-const :horizont ':value :value 'NIL)))
  9797.           )
  9798.           (HANDLER-OPEN
  9799.             (setq item
  9800.               (let ((v (const-value (second item)))
  9801.                     (k (spdepth-difference (third item) *func*)))
  9802.                 ; Aus v = #(type1 ... typem) mache v = #(type1 nil ... typem nil)
  9803.                 (setq v (coerce (mapcap #'(lambda (x) (list x nil)) (coerce v 'list)) 'vector))
  9804.                 `(HANDLER-OPEN ,(constvalue-index (cons v k)) ,v ,k ,@(cdddr item))
  9805.             ) )
  9806.             (push item *code-part*)
  9807.             (dolist (label (cddddr item)) (push item (symbol-value label)))
  9808.           )
  9809.           (VALUES0
  9810.             (push item *code-part*)
  9811.             (setq *current-value* 'FALSE *current-vars* '())
  9812.           )
  9813.           ((SKIP SKIPI SKIPSP VALUES1 MVCALLP BLOCK-CLOSE TAGBODY-CLOSE
  9814.             CATCH-CLOSE UNWIND-PROTECT-NORMAL-EXIT HANDLER-BEGIN
  9815.             STORE ; STORE nur auf Funktionsargumente innerhalb eines
  9816.                   ; Funktionsaufrufs, vgl. c-DIRECT-FUNCTION-CALL
  9817.            )
  9818.             (push item *code-part*)
  9819.           )
  9820.           ((T)
  9821.             (push item *code-part*)
  9822.             (setq *current-value* 'TRUE *current-vars* (list (make-const :horizont ':value :value 'T)))
  9823.           )
  9824.           ((RET BARRIER THROW)
  9825.             (push item *code-part*)
  9826.             (finish-code-part)
  9827.             (setq *dead-code* t)
  9828.           )
  9829.           (JMP
  9830.             (emit-jmp (second item))
  9831.             (setq *dead-code* t)
  9832.           )
  9833.           (JSR
  9834.             (push item *code-part*)
  9835.             (push item (symbol-value (third item)))
  9836.             (setq *current-value* nil *current-vars* '())
  9837.           )
  9838.           ((CATCH-OPEN UNWIND-PROTECT-OPEN)
  9839.             (push item *code-part*)
  9840.             (push item (symbol-value (second item)))
  9841.           )
  9842.           (UNWIND-PROTECT-CLOSE
  9843.             (push item *code-part*)
  9844.             (push item (symbol-value (second item)))
  9845.             (setq *current-value* nil *current-vars* '()) ; Werte werden weggeworfen
  9846.           )
  9847.           ((PUSH-NIL PROGV PUSH POP MAKE-VECTOR1&PUSH CALLS1 CALLS2 CALLSR
  9848.             CALLC CALLCKEY FUNCALL APPLY PUSH-UNBOUND UNLIST UNLIST*
  9849.             STACK-TO-MV MV-TO-STACK NV-TO-STACK MV-TO-LIST LIST-TO-MV MVCALL
  9850.             NOT EQ CAR CDR ATOM CONSP SYMBOL-FUNCTION SVREF SVSET
  9851.            )
  9852.             (push item *code-part*)
  9853.             (setq *current-value* nil *current-vars* '())
  9854.           )
  9855.           ((CONS LIST LIST*)
  9856.             (push item *code-part*)
  9857.             (setq *current-value* 'TRUE *current-vars* '())
  9858.           )
  9859.           ((UNWIND-PROTECT-CLEANUP)
  9860.             (push item *code-part*)
  9861.             (setq *current-vars* '()) ; Kann Variablenwerte zerst÷ren
  9862.           )
  9863.           ((UNBIND1)
  9864.             (push item *code-part*)
  9865.             (setq *current-vars* (delete-if #'symbolp *current-vars*)) ; Kann Werte dynamischer Variablen zerst÷ren
  9866.           )
  9867.           (t (compiler-error 'traverse-anode "LISTITEM"))
  9868. ) ) ) ) )
  9869.  
  9870. ; Hilfsfunktionen nach dem 1. Schritt:
  9871.  
  9872. ; Kommt eine Instruktion item dazu, die vielleicht Label-Referenzen enthΣlt,
  9873. ; so ist note-references aufzurufen. Dieses notiert die Label-Referenzen in
  9874. ; item. item geh÷re zu (aref *code-parts* index).
  9875. ; Wird eine Instruktion item entfernt, die vielleicht Label-Referenzen enthΣlt,
  9876. ; so ist remove-references aufzurufen. Dieses notiert das Wegfallen der
  9877. ; Label-Referenzen in item. item geh÷re zu (aref *code-parts* index).
  9878. ; Liefert auch die Liste der in item enthaltenen Labels.
  9879. (macrolet ((references ()
  9880.              `(case (first item)
  9881.                 (JMP (end-ref (second item)))
  9882.                 ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  9883.                  (end-ref (second item)) (end-ref (third item))
  9884.                 )
  9885.                 (JMPHASH (dolist (label (cdddr item)) (end-ref label)))
  9886.                 ((JMPIFBOUNDP CATCH-OPEN UNWIND-PROTECT-OPEN UNWIND-PROTECT-CLOSE)
  9887.                  (mid-ref (second item))
  9888.                 )
  9889.                 ((BLOCK-OPEN JSR) (mid-ref (third item)))
  9890.                 (JMPTAIL (mid-ref (fourth item)))
  9891.                 (TAGBODY-OPEN (dolist (label (cddr item)) (mid-ref label)))
  9892.                 (HANDLER-OPEN (dolist (label (cddddr item)) (mid-ref label)))
  9893.               )
  9894.           ))
  9895.   (defun note-references (item &optional index)
  9896.     (macrolet ((end-ref (label) `(push index (symbol-value ,label)))
  9897.                (mid-ref (label) `(push item (symbol-value ,label))))
  9898.       (references)
  9899.   ) )
  9900.   (defun remove-references (item &optional index &aux (labellist '()))
  9901.     (macrolet ((end-ref (label)
  9902.                  (let ((labelvar (gensym)))
  9903.                    `(let ((,labelvar ,label))
  9904.                       (setf (symbol-value ,labelvar) (delete index (symbol-value ,labelvar)))
  9905.                       (pushnew ,labelvar labellist)
  9906.                     )
  9907.                ) )
  9908.                (mid-ref (label)
  9909.                  (let ((labelvar (gensym)))
  9910.                    `(let ((,labelvar ,label))
  9911.                       (setf (symbol-value ,labelvar) (delete item (symbol-value ,labelvar)))
  9912.                       (pushnew ,labelvar labellist)
  9913.                     )
  9914.               )) )
  9915.       (references)
  9916.       labellist
  9917.   ) )
  9918. )
  9919.  
  9920. #|
  9921.                               2. Schritt
  9922.                 Vereinfachung von Folgen von Operationen
  9923.  
  9924. Dieses spielt sich auf umgedrehten Codestⁿcken ab; sie werden dabei destruktiv
  9925. verΣndert.
  9926.  
  9927. Vereinfachungsregeln fⁿr Operationen:
  9928.  
  9929. 1. (VALUES1) darf nach allen Instruktionen gestrichen werden, die sowieso nur
  9930.    einen Wert produzieren, und vor allen, die sowieso nur einen verwenden.
  9931.  
  9932. 2. (SKIP n1) (SKIP n2)                   --> (SKIP n1+n2)
  9933.    (SKIPI k1 k2 n1) (SKIP n2)            --> (SKIPI k1 k2 n1+n2)
  9934.    (SKIP n1) (SKIPI k1 k2 n2)            --> (SKIPI k1 k2 n2)
  9935.    (SKIPI k11 k21 n1) (SKIPI k21 k22 n2) --> (SKIPI k11+k12+1 k21+k22 n2)
  9936.    (SKIPSP k11 k21) (SKIPI k21 k22 n)    --> (SKIPI k11+k12 k21+k22 n)
  9937.    (SKIPSP k11 k21) (SKIPSP k21 k22)     --> (SKIPSP k11+k12 k21+k22)
  9938.  
  9939. 3. (NOT) (NOT) (NOT)                 --> (NOT)
  9940.    (ATOM) (NOT)                      --> (CONSP)
  9941.    (CONSP) (NOT)                     --> (ATOM)
  9942.  
  9943. 4. (LOAD 0) (SKIP n)                 --> (POP) (SKIP n-1)  fⁿr n>1
  9944.    (LOAD 0) (SKIP 1)                 --> (POP)             fⁿr n=1
  9945.    (PUSH) (SKIP n)                   --> (SKIP n-1)  fⁿr n>1
  9946.    (PUSH) (SKIP 1)                   -->             fⁿr n=1
  9947.    (NV-TO-STACK n) (SKIP n)          -->
  9948.    (NV-TO-STACK n+m) (SKIP n)        --> (NV-TO-STACK m)
  9949.    (NV-TO-STACK n) (SKIP n+m)        --> (SKIP m)
  9950.    (STORE m) (SKIP n)                --> (VALUES1) (SKIP n) fⁿr n>m
  9951.    (STORE 0) (POP)                   --> (VALUES1) (SKIP 1)
  9952.    (PUSH) (POP)                      --> (VALUES1)
  9953.    (POP) (PUSH)                      -->
  9954.    (SKIP n) (PUSH)                   --> (SKIP n-1) (STORE 0) fⁿr n>1
  9955.    (SKIP 1) (PUSH)                   --> (STORE 0)            fⁿr n=1
  9956.  
  9957. 5. (VALUES1)/... (MV-TO-STACK)       --> (VALUES1)/... (PUSH)
  9958.    (VALUES0) (MV-TO-STACK)           -->
  9959.    (STACK-TO-MV n) (MV-TO-STACK)     -->
  9960.    (STACK-TO-MV m) (NV-TO-STACK n)   --> (PUSH-NIL n-m)  fⁿr m<n
  9961.                                      -->                 fⁿr m=n
  9962.                                      --> (SKIP m-n)      fⁿr m>n
  9963.    (NIL)/(VALUES0) (NV-TO-STACK n)   --> (PUSH-NIL n)
  9964.    (VALUES1)/... (NV-TO-STACK n)     --> (VALUES1)/... (PUSH) (PUSH-NIL n-1)
  9965.  
  9966. 6. (PUSH-UNBOUND n) (PUSH-UNBOUND m) --> (PUSH-UNBOUND n+m)
  9967.  
  9968. 7. (LIST* 1)                         --> (CONS)
  9969.  
  9970. |#
  9971.  
  9972. ; Die Hash-Tabelle one-value-ops enthΣlt diejenigen Befehle,
  9973. ; die genau einen Wert erzeugen.
  9974. (defconstant one-value-ops
  9975.   (let ((ht (make-hash-table :test #'eq)))
  9976.     (dolist (op '(NIL T CONST LOAD LOADI LOADC LOADV LOADIC STORE STOREI
  9977.                   STOREC STOREV STOREIC GETVALUE SETVALUE POP VENV
  9978.                   COPY-CLOSURE BOUNDP VALUES1 MV-TO-LIST TAGBODY-CLOSE-NIL
  9979.                   NOT EQ CAR CDR CONS ATOM CONSP SYMBOL-FUNCTION SVREF SVSET
  9980.                   LIST LIST*
  9981.             )    )
  9982.       (setf (gethash op ht) t)
  9983.     )
  9984.     ht
  9985. ) )
  9986.  
  9987. ; Der Wert zu einem Key in dieser Hash-Tabelle gibt an, wieviele Werte bei
  9988. ; der Ausfⁿhrung der entsprechenden Operation ben÷tigt werden
  9989. ; (vgl. *for-value*):
  9990. ; NIL : Werte werden weggeworfen.
  9991. ; ONE : Ein Wert wird verwendet, die ⁿbrigen weggeworfen.
  9992. ; ALL : Alle Werte werden verwendet.
  9993. ; Operationen, die ihre Werte nicht verΣndern, werden hierin nicht
  9994. ; aufgefⁿhrt.
  9995. (defconstant for-value-table
  9996.   (let ((ht (make-hash-table :test #'eq)))
  9997.     (dolist (op '(NIL PUSH-NIL T CONST LOAD LOADI LOADC LOADV LOADIC
  9998.                   GETVALUE POP JSR JMPTAIL BARRIER VENV COPY-CLOSURE CALL
  9999.                   CALL0 CALLS1 CALLS2 CALLSR FUNCALL PUSH-UNBOUND JMPIFBOUNDP
  10000.                   BOUNDP VALUES0 STACK-TO-MV MVCALL
  10001.                   BLOCK-OPEN TAGBODY-OPEN TAGBODY-CLOSE-NIL GO GO-I
  10002.                   UNWIND-PROTECT-OPEN UNWIND-PROTECT-CLOSE
  10003.                   HANDLER-OPEN HANDLER-BEGIN
  10004.                   LIST
  10005.             )    )
  10006.       (setf (gethash op ht) 'NIL)
  10007.     )
  10008.     (dolist (op '(STORE STOREI STOREC STOREV STOREIC SETVALUE BIND PROGV PUSH
  10009.                   MAKE-VECTOR1&PUSH CALL1 CALL2 CALLC CALLCKEY APPLY UNLIST
  10010.                   UNLIST* VALUES1 LIST-TO-MV MVCALLP CATCH-OPEN
  10011.                   NOT EQ CAR CDR CONS ATOM CONSP SYMBOL-FUNCTION SVREF SVSET
  10012.                   LIST*
  10013.             )    )
  10014.       (setf (gethash op ht) 'ONE)
  10015.     )
  10016.     (dolist (op '(MV-TO-STACK NV-TO-STACK MV-TO-LIST RETURN-FROM RETURN-FROM-I
  10017.                   THROW UNWIND-PROTECT-NORMAL-EXIT
  10018.             )    )
  10019.       (setf (gethash op ht) 'ALL)
  10020.     )
  10021.     ; Nicht in der Tabelle, weil sie die Werte unverΣndert lassen:
  10022.     ;           '(UNBIND1 SKIP SKIPI SKIPSP BLOCK-CLOSE TAGBODY-CLOSE
  10023.     ;             CATCH-CLOSE UNWIND-PROTECT-CLEANUP
  10024.     ;            )
  10025.     ; Nicht in der Tabelle, weil es Wegsprⁿnge sind:
  10026.     ;   ONE:    '(JMPHASH)
  10027.     ;   ALL:    '(RET JMP JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10028.     ht
  10029. ) )
  10030.  
  10031. ; Vereinfacht ein Codestⁿck (in umgedrehter Reihenfolge!).
  10032. ; Obige Vereinfachungsregeln werden durchgefⁿhrt, solange es geht.
  10033. ; Ergebnis ist meist NIL, oder aber (um anzuzeigen, da▀ weitere Optimierungen
  10034. ; m÷glich sind) das Anfangslabel, falls sich dessen Property for-value
  10035. ; abgeschwΣcht hat.
  10036. (defun simplify (codelist)
  10037.   (let ((for-value-at-end
  10038.           (let ((item (car codelist)))
  10039.             (case (first item)
  10040.               (JMP (get (second item) 'for-value))
  10041.               ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10042.                 (if (or (and (not (eq (first item) 'JMPCASE1-TRUE))
  10043.                              (eq (get (second item) 'for-value) 'ALL)
  10044.                         )
  10045.                         (and (not (eq (first item) 'JMPCASE1-FALSE))
  10046.                              (eq (get (third item) 'for-value) 'ALL)
  10047.                     )   )
  10048.                   'ALL
  10049.                   'ONE
  10050.               ) )
  10051.               (JMPHASH 'ONE)
  10052.               ((BARRIER GO GO-I JMPTAIL) 'NIL)
  10053.               ((RETURN-FROM RETURN-FROM-I RET THROW) 'ALL)
  10054.               (t (compiler-error 'simplify "AT-END"))
  10055.         ) ) )
  10056.         (result nil)) ; evtl. das Anfangslabel
  10057.     ; for-value-at-end zeigt an, welche Werte vor dem Wegsprung ben÷tigt werden.
  10058.     (loop
  10059.       (let ((modified nil))
  10060.         (let* ((links codelist) (mitte (cdr links)) rechts (for-value for-value-at-end))
  10061.           ; Es wandern drei Pointer durch die Codeliste: ...links.mitte.rechts...
  10062.           ; for-value zeigt an, was fⁿr Werte nach Ausfⁿhrung von (car mitte),
  10063.           ; vor Ausfⁿhrung von (car links), gebraucht werden.
  10064.           (loop
  10065.             nochmal
  10066.             (when (atom mitte) (return))
  10067.             (setq rechts (cdr mitte))
  10068.             (macrolet ((ersetze1 (new) ; ersetze (car mitte) durch new
  10069.                          `(progn
  10070.                             (setf (car mitte) ,new)
  10071.                             (setq modified t) (go nochmal)
  10072.                           )
  10073.                        )
  10074.                        (ersetze2 (new) ; ersetze (car mitte) und (car rechts) durch new
  10075.                          `(progn
  10076.                             ,@(unless (equal new '(car mitte))
  10077.                                 `((setf (car mitte) ,new))
  10078.                               )
  10079.                             (setf (cdr mitte) (cdr rechts))
  10080.                             (setq modified t) (go nochmal)
  10081.                           )
  10082.                        )
  10083.                        (streiche1 () ; streiche (car mitte) ersatzlos
  10084.                          `(progn
  10085.                             (setf (cdr links) (setq mitte rechts))
  10086.                             (setq modified t) (go nochmal)
  10087.                           )
  10088.                        )
  10089.                        (streiche2 () ; streiche (car mitte) und (car rechts) ersatzlos
  10090.                          `(progn
  10091.                             (setf (cdr links) (setq mitte (cdr rechts)))
  10092.                             (setq modified t) (go nochmal)
  10093.                           )
  10094.                        )
  10095.                        (erweitere2 (new1 new2) ; ersetze (car mitte) durch new1 und new2
  10096.                          `(progn
  10097.                             (setf (car mitte) ,new1)
  10098.                             (setf (cdr mitte) (cons ,new2 rechts))
  10099.                             (setq modified t) (go nochmal)
  10100.                           )
  10101.                       ))
  10102.               (when (eq for-value 'NIL)
  10103.                 ; vor einer Operation, die keine Werte braucht:
  10104.                 (case (first (car mitte))
  10105.                   ((NIL T CONST LOAD LOADI LOADC LOADV LOADIC GETVALUE VENV
  10106.                     BOUNDP VALUES0 VALUES1 MV-TO-LIST LIST-TO-MV NOT CAR CDR
  10107.                     SYMBOL-FUNCTION ATOM CONSP
  10108.                    )
  10109.                     (streiche1)
  10110.                   )
  10111.                   ((LIST LIST* STACK-TO-MV) ; (LIST n) --> (SKIP n), n>0
  10112.                                             ; (LIST* n) --> (SKIP n), n>0
  10113.                                             ; (STACK-TO-MV n) --> (SKIP n), n>0
  10114.                     (ersetze1 `(SKIP ,(second (car mitte))))
  10115.                   )
  10116.                   ((POP EQ CONS SVREF) (ersetze1 '(SKIP 1)))
  10117.               ) )
  10118.               (when (eq for-value 'ONE)
  10119.                 ; vor einer Operation, die nur einen Wert braucht:
  10120.                 (case (first (car mitte))
  10121.                   (VALUES1 (streiche1))
  10122.                   (VALUES0 (ersetze1 '(NIL)))
  10123.                   (LIST-TO-MV (ersetze1 '(CAR)))
  10124.                   (STACK-TO-MV ; (STACK-TO-MV n) --> (SKIP n-1) (POP) fⁿr n>1
  10125.                     (let ((n (second (car mitte))))
  10126.                       (erweitere2 '(POP) `(SKIP ,(- n 1)))
  10127.               ) ) ) )
  10128.               (when (consp rechts)
  10129.                 ; Gucklock umfa▀t (car mitte) und (car rechts), evtl. auch mehr.
  10130.                 (case (first (car mitte))
  10131.                   (VALUES1 ; Regel 1
  10132.                     (when (gethash (first (car rechts)) one-value-ops nil)
  10133.                       ; (op ...) (VALUES1) --> (op ...)
  10134.                       (streiche1)
  10135.                   ) )
  10136.                   (NOT ; Regel 3
  10137.                     (case (first (car rechts))
  10138.                       (NOT
  10139.                         (when (and (consp (cdr rechts))
  10140.                                    (equal (cadr rechts) '(NOT))
  10141.                               )
  10142.                           ; (NOT) (NOT) (NOT) --> (NOT)
  10143.                           (streiche2)
  10144.                       ) )
  10145.                       (ATOM (ersetze2 '(CONSP))) ; (ATOM) (NOT) --> (CONSP)
  10146.                       (CONSP (ersetze2 '(ATOM))) ; (CONSP) (NOT) --> (ATOM)
  10147.                   ) )
  10148.                   (SKIP
  10149.                     (let ((n2 (second (car mitte)))) ; n2 > 0
  10150.                       (case (first (car rechts))
  10151.                         ; Regel 2
  10152.                         (SKIP ; (SKIP n1) (SKIP n2) --> (SKIP n1+n2)
  10153.                           (let ((n1 (second (car rechts))))
  10154.                             (ersetze2 `(SKIP ,(+ n1 n2)))
  10155.                         ) )
  10156.                         (SKIPI ; (SKIPI k1 k2 n1) (SKIP n2) --> (SKIPI k1 k2 n1+n2)
  10157.                           (let ((k1 (second (car rechts)))
  10158.                                 (k2 (third (car rechts)))
  10159.                                 (n1 (fourth (car rechts))))
  10160.                             (ersetze2 `(SKIPI ,k1 ,k2 ,(+ n1 n2)))
  10161.                         ) )
  10162.                         ; Regel 4
  10163.                         (LOAD ; (LOAD 0) (SKIP n) --> (POP) [(SKIP n-1)]
  10164.                           (when (eql (second (car rechts)) 0)
  10165.                             (if (eql n2 1)
  10166.                               (ersetze2 '(POP))
  10167.                               (progn (setf (car rechts) '(POP))
  10168.                                      (ersetze1 `(SKIP ,(- n2 1)))
  10169.                         ) ) ) )
  10170.                         (PUSH ; (PUSH) (SKIP n) --> [(SKIP n-1)]
  10171.                           (if (eql n2 1)
  10172.                             (streiche2)
  10173.                             (ersetze2 `(SKIP ,(- n2 1)))
  10174.                         ) )
  10175.                         (NV-TO-STACK
  10176.                           (let ((n1 (second (car rechts))))
  10177.                             (cond ((> n1 n2) (ersetze2 `(NV-TO-STACK ,(- n1 n2))))
  10178.                                   ((< n1 n2) (ersetze2 `(SKIP ,(- n2 n1))))
  10179.                                   (t (streiche2))
  10180.                         ) ) )
  10181.                         (STORE ; (STORE m) (SKIP n) --> (VALUES1) (SKIP n) fⁿr n>m
  10182.                           (let ((m (second (car rechts))))
  10183.                             (when (> n2 m)
  10184.                               (setf (car rechts) '(VALUES1))
  10185.                               (setq modified t) (go nochmal)
  10186.                   ) ) ) ) ) )
  10187.                   (SKIPI ; Regel 2
  10188.                     (case (first (car rechts))
  10189.                       (SKIP ; (SKIP n1) (SKIPI k1 k2 n2) --> (SKIPI k1 k2 n2)
  10190.                         (ersetze2 (car mitte))
  10191.                       )
  10192.                       (SKIPI ; (SKIPI k11 k21 n1) (SKIPI k21 k22 n2) --> (SKIPI k11+k12+1 k21+k22 n2)
  10193.                         (let ((k11 (second (car rechts)))
  10194.                               (k21 (third (car rechts)))
  10195.                               (k12 (second (car mitte)))
  10196.                               (k22 (third (car mitte)))
  10197.                               (n2 (third (car mitte))))
  10198.                           (ersetze2 `(SKIPI ,(+ k11 k12 1) ,(+ k21 k22) ,n2))
  10199.                       ) )
  10200.                       (SKIPSP ; (SKIPSP k11 k21) (SKIPI k21 k22 n) --> (SKIPI k11+k12 k21+k22 n)
  10201.                         (let ((k11 (second (car rechts)))
  10202.                               (k21 (third (car rechts)))
  10203.                               (k12 (second (car mitte)))
  10204.                               (k22 (third (car mitte)))
  10205.                               (n2 (third (car mitte))))
  10206.                           (ersetze2 `(SKIPI ,(+ k11 k12) ,(+ k21 k22) ,n2))
  10207.                   ) ) ) )
  10208.                   (SKIPSP ; Regel 2
  10209.                     (case (first (car rechts))
  10210.                       (SKIPSP ; (SKIPSP k11 k21) (SKIPSP k21 k22) --> (SKIPSP k11+k12 k21+k22)
  10211.                         (let ((k11 (second (car rechts)))
  10212.                               (k21 (third (car rechts)))
  10213.                               (k12 (second (car mitte)))
  10214.                               (k22 (third (car mitte))))
  10215.                           (ersetze2 `(SKIPSP ,(+ k11 k12) ,(+ k21 k22)))
  10216.                   ) ) ) )
  10217.                   (POP ; Regel 4
  10218.                     (cond ((equal (car rechts) '(STORE 0))
  10219.                             ; (STORE 0) (POP) --> (VALUES1) (SKIP 1)
  10220.                             (setf (car rechts) '(VALUES1))
  10221.                             (ersetze1 '(SKIP 1))
  10222.                           )
  10223.                           ((equal (car rechts) '(PUSH))
  10224.                             ; (PUSH) (POP) --> (VALUES1)
  10225.                             (ersetze2 '(VALUES1))
  10226.                   ) )     )
  10227.                   (PUSH ; Regel 4
  10228.                     (case (first (car rechts))
  10229.                       (POP (streiche2)) ; (POP) (PUSH) streichen
  10230.                       (SKIP ; (SKIP n) (PUSH) --> [(SKIP n-1)] (STORE 0)
  10231.                         (let ((n (second (car rechts))))
  10232.                           (if (eql n 1)
  10233.                             (unless (and (consp (cdr rechts)) (equal (cadr rechts) '(LOAD 0)))
  10234.                               ; (LOAD 0) (SKIP 1) (PUSH) wird anders behandelt
  10235.                               (ersetze2 '(STORE 0))
  10236.                             )
  10237.                             (progn (setf (car rechts) `(SKIP ,(- n 1)))
  10238.                                    (ersetze1 '(STORE 0))
  10239.                   ) ) ) ) ) )
  10240.                   (MV-TO-STACK ; Regel 5
  10241.                     (when (gethash (first (car rechts)) one-value-ops nil)
  10242.                       ; (car rechts) liefert nur einen Wert -->
  10243.                       ; (MV-TO-STACK) durch (PUSH) ersetzen:
  10244.                       (ersetze1 '(PUSH))
  10245.                     )
  10246.                     (case (first (car rechts))
  10247.                       ((VALUES0 STACK-TO-MV) (streiche2))
  10248.                   ) )
  10249.                   (NV-TO-STACK ; Regel 5
  10250.                     (let ((n (second (car mitte))))
  10251.                       (case (first (car rechts))
  10252.                         (STACK-TO-MV
  10253.                           (let ((m (second (car rechts))))
  10254.                             (cond ((> n m) (ersetze2 `(PUSH-NIL ,(- n m))))
  10255.                                   ((< n m) (ersetze2 `(SKIP ,(- m n))))
  10256.                                   (t (streiche2))
  10257.                         ) ) )
  10258.                         ((VALUES0 NIL) (ersetze2 `(PUSH-NIL ,n)))
  10259.                         (t (when (gethash (first (car rechts)) one-value-ops nil)
  10260.                              (erweitere2 `(PUSH-NIL ,(- n 1)) `(PUSH))
  10261.                   ) ) ) )  )
  10262.                   (PUSH-UNBOUND ; Regel 6
  10263.                     (case (first (car rechts))
  10264.                       (PUSH-UNBOUND ; (PUSH-UNBOUND n) (PUSH-UNBOUND m) --> (PUSH-UNBOUND n+m)
  10265.                         (let ((n (second (car rechts)))
  10266.                               (m (second (car mitte))))
  10267.                           (ersetze2 `(PUSH-UNBOUND ,(+ n m)))
  10268.                   ) ) ) )
  10269.                   (LIST* ; Regel 7
  10270.                     (when (equal (rest (car mitte)) '(1))
  10271.                       (ersetze1 '(CONS))
  10272.                   ) )
  10273.             ) ) )
  10274.             (when (atom mitte) (return))
  10275.             ; Neues for-value berechnen, in AbhΣngigkeit von (car mitte):
  10276.             (setq for-value
  10277.               (gethash (first (car mitte)) for-value-table for-value)
  10278.             )
  10279.             ; weiterrⁿcken:
  10280.             (setq links mitte mitte rechts)
  10281.           )
  10282.           ; Codestⁿck zu Ende: (atom mitte)
  10283.           (when mitte
  10284.             ; mitte ist das Anfangslabel
  10285.             (let ((old-for-value (get mitte 'for-value)))
  10286.               ; Ist for-value besser als old-for-value ?
  10287.               (when (and (not (eq for-value old-for-value))
  10288.                          (or (eq old-for-value 'ALL) (eq for-value 'NIL))
  10289.                     )
  10290.                 ; ja -> Anfangslabel nachher als Ergebnis bringen:
  10291.                 (setf (get mitte 'for-value) for-value result mitte)
  10292.           ) ) )
  10293.         ) ; end let*
  10294.         (unless modified (return))
  10295.     ) ) ; end let, loop
  10296.     (let (codelistr)
  10297.       (when (and (eq (first (first codelist)) 'RET)
  10298.                  (consp (setq codelistr (cdr codelist)))
  10299.                  (or (eq (first (first codelistr)) 'JSR)
  10300.                      (and (eq (first (second codelist)) 'SKIP)
  10301.                           (consp (setq codelistr (cddr codelist)))
  10302.                           (eq (first (first codelistr)) 'JSR)
  10303.             )    )   )
  10304.         ; (JSR n label) [(SKIP m)] (RET) --> (JMPTAIL n n+m label)
  10305.         (let ((n (second (first codelistr)))
  10306.               (label (third (first codelistr)))
  10307.               (m (if (eq codelistr (cdr codelist)) 0 (second (second codelist)))))
  10308.           (setf (first codelist) `(JMPTAIL ,n ,(+ n m) ,label))
  10309.         )
  10310.         (remove-references (first codelistr)) ; (JSR ...) wird gestrichen
  10311.         (note-references (first codelist)) ; (JMPTAIL ...) wird eingefⁿgt
  10312.         (setf (cdr codelist) (cdr codelistr)) ; ein bzw. zwei Listenelemente streichen
  10313.         (setq for-value-at-end 'NIL) ; JMPTAIL braucht keine Werte
  10314.     ) )
  10315.     result
  10316. ) )
  10317.  
  10318. #|
  10319.                             3. Schritt:
  10320.                       Allgemeine Optimierungen
  10321.  
  10322. Wird eine Optimierung erfolgreich durchgefⁿhrt, so werden alle weiteren
  10323. Optimierungen nochmal probiert, die sich deswegen ergeben k÷nnten.
  10324.  
  10325. optimize-part    - ruft den 2. Schritt auf:
  10326.                    Peephole-Optimierung normaler Operationen.
  10327.  
  10328. optimize-label   - Codestⁿcke zu Labels, die nicht (mehr) referenziert werden,
  10329.                    werden entfernt.
  10330.                  - Wird ein Label nur von einem einzigen JMP referenziert,
  10331.                    der nicht vom selben Codestⁿck kommt, k÷nnen die beiden
  10332.                    betroffenen Stⁿcke aneinandergehΣngt werden.
  10333.  
  10334. optimize-short   - Liegt ein Codestⁿck vor, wo auf das Anfangslabel label1
  10335.                    sofort ein (JMP label2) folgt, so werden alle Referenzen
  10336.                    von label1 durch label2 ersetzt und das Codestⁿck entfernt.
  10337.                  - Liegt ein Codestⁿck vor, wo auf das Anfangslabel label
  10338.                    sofort ein
  10339.                    (JMPCASE/JMPCASE1-TRUE/JMPCASE1-FALSE label_true label_false)
  10340.                    folgt, so k÷nnen Referenzen (JMPCASE1-TRUE label l) und
  10341.                    (JMPCASE1-FALSE l label) vereinfacht werden.
  10342.                  - Ein kurzes Codestⁿck wird direkt an zugeh÷rige JMPs auf
  10343.                    sein Anfangslabel angehΣngt. (Ein Codestⁿck hei▀t "kurz",
  10344.                    wenn es h÷chstens 2 Befehle umfa▀t und nicht mit einem
  10345.                    JMPHASH (den man nicht duplizieren sollte) abgeschlossen
  10346.                    ist. Auch HANDLER-OPEN sollte man nicht duplizieren.)
  10347.  
  10348. optimize-jmpcase - (JMPCASE label label) wird vereinfacht zu (JMP label).
  10349.                  - (NOT) [...] (JMPCASE label_true label_false) wird
  10350.                    vereinfacht zu [...] (JMPCASE label_false label_true),
  10351.                    wobei [...] nur Befehle enthalten darf, die den 1. Wert
  10352.                    nicht verΣndern, und bei label_true und label_false keine
  10353.                    Werte gebraucht werden.
  10354.  
  10355. optimize-value   - Ein Wegsprung JMPCASE1-TRUE/JMPCASE1-FALSE kann durch
  10356.                    JMPCASE ersetzt werden, wenn am Ziel-Label der Wert
  10357.                    nicht gebraucht oder nur der 1. Wert gebraucht wird.
  10358.                  - Ein Wegsprung JMPCASE/JMPCASE1-TRUE/JMPCASE1-FALSE kann
  10359.                    durch ein JMP ersetzt werden, wenn der aktuelle Wert an
  10360.                    dieser Stelle als =NIL oder als /=NIL nachgewiesen werden
  10361.                    kann.
  10362.                  - Ein JMP kann die Information, welcher Wert gerade vorliegt,
  10363.                    zu seinem Ziel-Label weitertragen.
  10364.  
  10365. coalesce         - Lege Codeteile mit gleichem Ende (mind. 3 Befehle) zusammen.
  10366.  
  10367. |#
  10368.  
  10369. (defun optimize-part (code)
  10370.   (let ((label (simplify code)))
  10371.     (when label
  10372.       ; Die Property for-value von label wurde verbessert.
  10373.       (dolist (ref (symbol-value label))
  10374.         (when (integerp ref) (optimize-value ref))
  10375. ) ) ) )
  10376.  
  10377. (defun optimize-label (label &optional (index (get label 'code-part))
  10378.                                        (code (aref *code-parts* index))
  10379.                                        (lastc (last code))
  10380.                       )
  10381.   (unless (eq label (cdr lastc)) (compiler-error 'optimize-label))
  10382.   (when label
  10383.     ; label ist ein Label, es beginnt den Code
  10384.     ; code = (aref *code-parts* index), und es ist lastc = (last code).
  10385.     (let ((refs (symbol-value label))) ; Liste der Referenzen darauf
  10386.       (cond ((null refs)
  10387.               ; nicht referenziertes Label: Codestⁿck entfernen,
  10388.               ; Referenzen aus diesem Codestⁿck heraus eliminieren.
  10389.               (let ((labellist '())) ; Liste von Labels, die Referenzen
  10390.                                      ; verloren haben
  10391.                 (loop
  10392.                   (when (atom code) (return))
  10393.                   (setq labellist
  10394.                     (nreconc labellist (remove-references (pop code) index))
  10395.                 ) )
  10396.                 (setf (aref *code-parts* index) nil) ; Codestⁿck entfernen
  10397.                 ; Bei Labels mit weniger Referenzen weiteroptimieren:
  10398.                 ; (Vorsicht: Hierdurch kann sich *code-parts* verΣndern.)
  10399.                 (dolist (olabel labellist)
  10400.                   (let* ((oindex (get olabel 'code-part))
  10401.                          (ocode (aref *code-parts* oindex)))
  10402.                     (when ocode
  10403.                       (optimize-label olabel oindex ocode)
  10404.                 ) ) )
  10405.             ) )
  10406.             ((null (cdr refs))
  10407.               ; Label mit nur einer Referenz, und zwar durch JMP ?
  10408.               (let ((ref (first refs)))
  10409.                 (when (and (integerp ref) ; Ein JMP ist ein Wegsprung
  10410.                            (eq (first (car (aref *code-parts* ref))) 'JMP)
  10411.                            (not (eql index ref)) ; aus anderem Codestⁿck
  10412.                       )
  10413.                   ; AnhΣngen:
  10414.                   ; (aref *code-parts* ref) wird in die Schublade
  10415.                   ; (aref *code-parts* index) gesteckt.
  10416.                   (setf (cdr lastc) (rest (aref *code-parts* ref)))
  10417.                   (setf (aref *code-parts* ref) nil)
  10418.                   (let ((new-startlabel (cdr (last lastc)))) ; neues Startlabel von (aref *code-parts* index)
  10419.                     (when new-startlabel
  10420.                       (setf (get new-startlabel 'code-part) index)
  10421.                   ) )
  10422.                   (setf (symbol-value label) '()) ; altes Startlabel von (aref *code-parts* index) deaktivieren
  10423.                   ; neues Codestⁿck vereinfachen:
  10424.                   (optimize-part code)
  10425. ) ) ) )     ) ) )
  10426.  
  10427. (defun optimize-short (index &optional (code (aref *code-parts* index))
  10428.                              &aux      (lastc (last code))
  10429.                                        (label (cdr lastc))
  10430.                       )
  10431.   (when label
  10432.     ; label ist ein Label, es beginnt den Code
  10433.     ; code = (aref *code-parts* index), und es ist lastc = (last code).
  10434.     (when (eq code lastc)
  10435.       ; Eine einzige Operation nach dem Label.
  10436.       (let ((item (car code)))
  10437.         (case (first item)
  10438.           (JMP ; (JMP ...) sofort nach dem Label
  10439.             (let ((to-label (second item)))
  10440.               (unless (eq label to-label)
  10441.                 (label-subst label to-label) ; Referenzen umbiegen
  10442.                 (setf (aref *code-parts* index) nil) ; Codestⁿck entfernen
  10443.                 (setf (symbol-value to-label)
  10444.                       (delete index (symbol-value to-label)) ; Referenz fΣllt weg
  10445.                 )
  10446.                 (optimize-label to-label) ; m÷gliche Optimierung
  10447.             ) )
  10448.             (return-from optimize-short)
  10449.           )
  10450.           ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10451.             (let ((true-label (second item))
  10452.                   (false-label (third item)))
  10453.               (unless (or (eq label true-label) (eq label false-label))
  10454.                 (macrolet ((err () `(compiler-error 'optimize-short)))
  10455.                   ; JMPCASE1-Referenzen auf label vereinfachen:
  10456.                   (let ((modified-indices '())) ; Indizes von modifizierten Codestⁿcken
  10457.                     (dolist (refindex (symbol-value label))
  10458.                       (when (integerp refindex)
  10459.                         (let* ((refcode (aref *code-parts* refindex))
  10460.                                (ref (car refcode)))
  10461.                           (case (first ref)
  10462.                             (JMP
  10463.                               ; (JMP label) --> (JMPCASE/... true-label false-label)
  10464.                               (setf (car refcode) item)
  10465.                               ; neue Verweise auf true-label und false-label:
  10466.                               (push refindex (symbol-value true-label))
  10467.                               (push refindex (symbol-value false-label))
  10468.                               (push refindex modified-indices)
  10469.                             )
  10470.                             ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10471.                               ; (JMPCASE/... label1 label2)
  10472.                               (let ((label1 (second ref)) ; im TRUE-Fall: wohin springen
  10473.                                     (label2 (third ref)) ; im FALSE-Fall: wohin springen
  10474.                                     (1-true (eq (first ref) 'JMPCASE1-TRUE)) ; im TRUE-Fall: mit (VALUES1) ?
  10475.                                     (1-false (eq (first ref) 'JMPCASE1-FALSE))) ; im FALSE-Fall: mit (VALUES1) ?
  10476.                                 (when (eq label label1)
  10477.                                   ; Der (JMPCASE/... label ...) wird vereinfacht zu
  10478.                                   ; (JMPCASE/... true-label ...).
  10479.                                   (setq label1 true-label)
  10480.                                   ; neuer Verweis auf true-label:
  10481.                                   (push refindex (symbol-value true-label))
  10482.                                   (push refindex modified-indices)
  10483.                                   (when (eq (first item) 'JMPCASE1-TRUE)
  10484.                                     (setq 1-true t)
  10485.                                 ) )
  10486.                                 (when (eq label label2)
  10487.                                   ; Der (JMPCASE/... ... label) wird vereinfacht zu
  10488.                                   ; (JMPCASE/... ... false-label).
  10489.                                   (setq label2 false-label)
  10490.                                   ; neuer Verweis auf false-label:
  10491.                                   (push refindex (symbol-value false-label))
  10492.                                   (push refindex modified-indices)
  10493.                                   (when (eq (first item) 'JMPCASE1-FALSE)
  10494.                                     (setq 1-false t)
  10495.                                 ) )
  10496.                                 (unless (eq (get label1 'for-value) 'ALL)
  10497.                                   (setq 1-true nil)
  10498.                                 )
  10499.                                 (unless (eq (get label2 'for-value) 'ALL)
  10500.                                   (setq 1-false nil)
  10501.                                 )
  10502.                                 (when (and 1-true 1-false)
  10503.                                   (push '(VALUES1) (cdr refcode))
  10504.                                   (setq 1-true nil 1-false nil)
  10505.                                 )
  10506.                                 (setf (car refcode)
  10507.                                   `(,(cond (1-true 'JMPCASE1-TRUE)
  10508.                                            (1-false 'JMPCASE1-FALSE)
  10509.                                            (t 'JMPCASE)
  10510.                                      )
  10511.                                     ,label1
  10512.                                     ,label2
  10513.                                    )
  10514.                             ) ) )
  10515.                             (JMPHASH (err)) ; JMPHASH hat undefinierte Werte
  10516.                         ) )
  10517.                         ; spΣter:
  10518.                         ; (setf (symbol-value label) (delete refindex (symbol-value label)))
  10519.                     ) )
  10520.                     (setf (symbol-value label)
  10521.                           (delete-if #'integerp (symbol-value label))
  10522.                     )
  10523.                     ; evtl. Optimierung wegen verringerter Referenzen m÷glich:
  10524.                     (optimize-label label)
  10525.                     ; evtl. weitere Optimierung in verΣnderten Codeteilen:
  10526.                     (dolist (refindex modified-indices)
  10527.                       (simplify (aref *code-parts* refindex))
  10528.                       (optimize-value refindex)
  10529.                       (optimize-jmpcase refindex (aref *code-parts* refindex))
  10530.                     )
  10531.           ) ) ) ) )
  10532.     ) ) )
  10533.     ; Sonstige "kurze" Codestⁿcke, maximal 2 Operationen lang:
  10534.     (when (and (or (eq code lastc) (eq (cdr code) lastc))
  10535.                (not (eq (first (car code)) 'JMPHASH))
  10536.                (or (eq code lastc) (not (eq (first (cadr code)) 'HANDLER-OPEN)))
  10537.           )
  10538.       (let ((indices '())) ; Liste der Indizes der Codestⁿcke, an die wir code anhΣngen
  10539.         (setf (cdr lastc) '()) ; code vorlΣufig ohne das Label am Schlu▀
  10540.         (dolist (refindex (symbol-value label))
  10541.           (when (and (integerp refindex) (not (eql refindex index)))
  10542.             (let ((refcode (aref *code-parts* refindex)))
  10543.               (when (eq (first (car refcode)) 'JMP)
  10544.                 ; anhΣngen:
  10545.                 (let ((new-code (mapcar #'copy-list code)))
  10546.                   (dolist (op new-code) (note-references op refindex))
  10547.                   (setf (aref *code-parts* refindex) (nconc new-code (cdr refcode)))
  10548.                 )
  10549.                 (setf (symbol-value label) (delete refindex (symbol-value label)))
  10550.                 (push refindex indices)
  10551.         ) ) ) )
  10552.         (setf (cdr lastc) label) ; wieder das Label ans Listenende setzen
  10553.         (when indices
  10554.           ; m÷gliche weitere Optimierungen:
  10555.           (dolist (refindex indices)
  10556.             (optimize-part (aref *code-parts* refindex))
  10557.           )
  10558.           (optimize-label label) ; label hat weniger Referenzen -> optimieren
  10559.     ) ) )
  10560. ) )
  10561.  
  10562. ; get-boolean-value versucht zu einem Anfangsstⁿck eines Codestⁿcks
  10563. ; (einem (nthcdr n codelist) mit n>=1) zu bestimmen, welcher boolesche Wert
  10564. ; nach seiner Ausfⁿhrung vorliegt:
  10565. ; FALSE     sicher A0 = NIL,
  10566. ; TRUE      sicher A0 /= NIL,
  10567. ; NIL       keine Aussage.
  10568. (defun get-boolean-value (code)
  10569.   (macrolet ((err () `(compiler-error 'get-boolean-value)))
  10570.     (let ((invert nil)) ; ob von hier bis zum Ende der boolesche Wert invertiert wird
  10571.       ((lambda (value)
  10572.          (if invert
  10573.            (case value (TRUE 'FALSE) (FALSE 'TRUE) (t NIL))
  10574.            value
  10575.        ) )
  10576.        (block value
  10577.          (loop ; Codeliste durchlaufen
  10578.            (when (atom code) (return))
  10579.            (case (first (car code))
  10580.              ((NIL VALUES0 TAGBODY-CLOSE-NIL) ; produzieren Wert NIL
  10581.                (return-from value 'FALSE) ; Damit k÷nnen wir die Schleife abbrechen
  10582.              )
  10583.              ((T CONS LIST LIST*) ; produzieren Wert /= NIL
  10584.                ; (LIST n) und (LIST* n) wegen n>0.
  10585.                (return-from value 'TRUE) ; Damit k÷nnen wir die Schleife abbrechen
  10586.              )
  10587.              (CONST
  10588.                (unless (and (cddr (car code)) (eq (const-horizont (third (car code))) ':form))
  10589.                  ; (CONST n) produziert Wert /= NIL, weil der Wert schon zur
  10590.                  ; Compile-Zeit bekannt ist und die Konstante NIL in make-const-code
  10591.                  ; bereits speziell behandelt wurde.
  10592.                  (return-from value 'TRUE) ; Damit k÷nnen wir die Schleife abbrechen
  10593.                )
  10594.                (return-from value nil)
  10595.              )
  10596.              (NOT (setq invert (not invert))) ; invertiere spΣter den booleschen Wert
  10597.              ((UNBIND1 SKIP SKIPI SKIPSP STORE STOREI STOREV STOREC STOREIC SETVALUE
  10598.                VALUES1 BLOCK-CLOSE TAGBODY-CLOSE CATCH-CLOSE UNWIND-PROTECT-CLEANUP
  10599.              )) ; keine ─nderung des 1. Werts -> weiter in der Codeliste
  10600.              (t (return-from value nil))
  10601.            )
  10602.            (setq code (cdr code))
  10603.          )
  10604.          (when code
  10605.            ; code ist das Anfangslabel.
  10606.            ; Inspiziere alle Sprⁿnge auf das Label code:
  10607.            (let ((bisher nil))
  10608.              ; bisher = FALSE, falls bisher alle Sprⁿnge den booleschen Wert
  10609.              ;                 FALSE mitbringen,
  10610.              ; bisher = TRUE, falls bisher alle Sprⁿnge den booleschen Wert
  10611.              ;                TRUE mitbringen,
  10612.              ; bisher = NIL am Anfang.
  10613.              ; Falls ein Sprung einen unbekannten booleschen Wert mitbringt,
  10614.              ; kann man die Schleife gleich verlassen.
  10615.              (flet ((neu (value)
  10616.                       (cond ((null bisher) (setq bisher value))
  10617.                             ((not (eq value bisher)) (return-from value nil))
  10618.                    )) )
  10619.                (dolist (ref (symbol-value code))
  10620.                  (if (integerp ref)
  10621.                    (let ((refcode (first (aref *code-parts* ref)))) ; der Wegsprung hierher
  10622.                      ; Ein Wegsprung mit undefinierten Werten kann das nicht sein.
  10623.                      (case (first refcode)
  10624.                        (JMP
  10625.                          (if (third refcode)
  10626.                            ; Wert vor dem Sprung bekannt
  10627.                            (neu (third refcode))
  10628.                            ; Wert vor dem Sprung unbekannt
  10629.                            (return-from value nil)
  10630.                        ) )
  10631.                        ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10632.                          (when (eq code (second refcode)) (neu 'TRUE))
  10633.                          (when (eq code (third refcode)) (neu 'FALSE))
  10634.                        )
  10635.                        (t (err)) ; JMPHASH hat undefinierte Werte, und die
  10636.                                  ; anderen Wegsprⁿnge enthalten keine Labels.
  10637.                    ) )
  10638.                    (case (first ref)
  10639.                      ((JMPIFBOUNDP BLOCK-OPEN CATCH-OPEN)
  10640.                        (return-from value nil) ; Da k÷nnen wir nichts aussagen
  10641.                      )
  10642.                      (t (err)) ; An den Labels in TAGBODY-OPEN, JSR,
  10643.                                ; UNWIND-PROTECT-OPEN, UNWIND-PROTECT-CLOSE
  10644.                                ; liegen undefinierte Werte vor.
  10645.          ) ) ) ) ) )
  10646.          nil ; Default: nichts aussagbar
  10647.       ))
  10648. ) ) )
  10649.  
  10650. (defun optimize-jmpcase (index code)
  10651.   (when (eq (first (car code)) 'JMPCASE)
  10652.     ; Code endet mit (JMPCASE ...)
  10653.     (let ((true-label (second (car code)))
  10654.           (false-label (third (car code))))
  10655.       (if (eq true-label false-label)
  10656.         ; (JMPCASE label label) --> (JMP label ..)
  10657.         (progn
  10658.           (setf (car code) `(JMP ,true-label ,(get-boolean-value (cdr code))))
  10659.           ; doppelte Referenz wird zu einer einfachen:
  10660.           (setf (symbol-value true-label)
  10661.                 (delete index (symbol-value true-label) :count 1)
  10662.           )
  10663.           ; und weiter optimieren:
  10664.           (optimize-part code)
  10665.           (optimize-short (get true-label 'code-part))
  10666.         )
  10667.         (when (and (null (get true-label 'for-value))
  10668.                    (null (get false-label 'for-value))
  10669.               )
  10670.           ; Versuche NOTs zu eliminieren:
  10671.           (let ((invert 0)
  10672.                 (cr1 code)
  10673.                 (cr2 (cdr code))) ; stets cr2 = (cdr cr1)
  10674.             (loop
  10675.               (when (atom cr2) (return))
  10676.               (case (first (car cr2))
  10677.                 ((UNBIND1 SKIP SKIPI SKIPSP VALUES1 BLOCK-CLOSE TAGBODY-CLOSE
  10678.                   CATCH-CLOSE UNWIND-PROTECT-CLEANUP
  10679.                  ) ; diese Operationen brauchen keine Werte und lassen
  10680.                    ; den 1. Wert unverΣndert
  10681.                  (shiftf cr1 cr2 (cdr cr2))
  10682.                 )
  10683.                 (NOT
  10684.                   (setf (cdr cr1) (setq cr2 (cdr cr2))) ; (NOT) streichen
  10685.                   (incf invert)
  10686.                 )
  10687.                 (t (return))
  10688.             ) )
  10689.             ; invert = Anzahl, wie oft (NOT) gestrichen wurde
  10690.             (when (oddp invert)
  10691.               ; true-label und false-label vertauschen:
  10692.               (setf (car code) `(JMPCASE ,false-label ,true-label))
  10693.             )
  10694.             (when (plusp invert)
  10695.               ; und weiter optimieren:
  10696.               (optimize-part code)
  10697.               (optimize-short index)
  10698.         ) ) )
  10699. ) ) ) )
  10700.  
  10701. (defun optimize-value (index &optional (code (aref *code-parts* index)))
  10702.   (let ((item (car code)))
  10703.     (case (first item)
  10704.       ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10705.         ; (JMPCASE/... true-label false-label)
  10706.         (let ((true-label (second item))
  10707.               (false-label (third item)))
  10708.           (when (or (and (eq (first item) 'JMPCASE1-TRUE)
  10709.                          (not (eq (get true-label 'for-value) 'ALL))
  10710.                          ; Wertezahl 1 wird bei true-label nicht gebraucht
  10711.                          ; (JMPCASE1-TRUE ...) --> (JMPCASE ...)
  10712.                     )
  10713.                     (and (eq (first item) 'JMPCASE1-FALSE)
  10714.                          (not (eq (get false-label 'for-value) 'ALL))
  10715.                          ; Wertezahl 1 wird bei false-label nicht gebraucht
  10716.                          ; (JMPCASE1-FALSE ...) --> (JMPCASE ...)
  10717.                 )   )
  10718.             (setq item (setf (car code) `(JMPCASE ,@(rest item))))
  10719.             ; Weitere m÷gliche Optimierungen:
  10720.             (optimize-jmpcase index code)
  10721.           )
  10722.           ; Versuche, den booleschen Wert an dieser Stelle zu ermitteln
  10723.           ; und vereinfache gegebenenfalls:
  10724.           (case (get-boolean-value (cdr code))
  10725.             (TRUE ; Sprung geht immer auf true-label
  10726.               ; Referenz auf false-label streichen:
  10727.               (setf (symbol-value false-label)
  10728.                 (delete index (symbol-value false-label))
  10729.               )
  10730.               (setf (car code) `(JMP ,true-label TRUE))
  10731.               (when (eq (first item) 'JMPCASE1-TRUE)
  10732.                 (push '(VALUES1) (cdr code))
  10733.                 (simplify code)
  10734.               )
  10735.               (optimize-part code) ; weitere m÷gliche Optimierung
  10736.               ; weitere m÷gliche Optimierungen:
  10737.               (optimize-label false-label) ; wegen verringerter Referenzen
  10738.               (optimize-short index) ; wegen obigem optimize-part
  10739.             )
  10740.             (FALSE
  10741.               ; Referenz auf true-label streichen
  10742.               (setf (symbol-value true-label)
  10743.                 (delete index (symbol-value true-label))
  10744.               )
  10745.               (setf (car code) `(JMP ,false-label FALSE))
  10746.               (when (eq (first item) 'JMPCASE1-FALSE)
  10747.                 (push '(VALUES1) (cdr code))
  10748.                 (simplify code)
  10749.               )
  10750.               (optimize-part code) ; weitere m÷gliche Optimierung
  10751.               ; weitere m÷gliche Optimierungen:
  10752.               (optimize-label true-label) ; wegen verringerter Referenzen
  10753.               (optimize-short index) ; wegen obigem optimize-part
  10754.       ) ) ) )
  10755.       (JMP
  10756.         (let ((label (second item)))
  10757.           (when (get label 'for-value)
  10758.             ; Wert wird ben÷tigt
  10759.             (when (null (third item))
  10760.               ; aber er ist unbekannt.
  10761.               ; Vielleicht lΣ▀t sich der Wert herausbekommen ?
  10762.               (let ((value (get-boolean-value (cdr code))))
  10763.                 (when value
  10764.                   (setf (car code) `(JMP ,label ,value))
  10765.                   ; Wert jetzt bekannt, lΣ▀t sich vielleicht verwenden:
  10766.                   (optimize-value (get label 'code-part))
  10767. ) ) ) ) ) ) ) ) )
  10768.  
  10769. ; coalesce legt gleiche Codeteile in den gegebenen Codestⁿcken soweit wie
  10770. ; m÷glich zusammen und liefert als Ergebnis ein Flag, ob etwas geΣndert wurde.
  10771. (defun coalesce (&optional (indexlist
  10772.                              ; Liste aller m÷glichen Indizes
  10773.                              (let ((L '()))
  10774.                                (dotimes (i (fill-pointer *code-parts*)) (push i L))
  10775.                                (nreverse L)
  10776.                 )          ) )
  10777.   (let ((parts-ht ; Eine Hashtabelle, die eine Abbildung realisiert:
  10778.                   ; Codeende --> Liste aller Indizes von Codestⁿcken,
  10779.                   ;              die damit enden
  10780.           (let ((ht (make-hash-table :test #'equal :size (length indexlist))))
  10781.             (dolist (index indexlist)
  10782.               (let ((code (aref *code-parts* index))) ; ein Codestⁿck
  10783.                 ; Wegen der Vereinfachungsregel fⁿr "kurze" Codestⁿcke werden
  10784.                 ; nur Teile zusammengelegt, die in mindestens den letzten 3
  10785.                 ; Operationen ⁿbereinstimmen.
  10786.                 (when (and (consp code) (consp (cdr code)) (consp (cddr code)))
  10787.                   (push index
  10788.                     (gethash (list* (first code) (second code) (third code))
  10789.                              ht '()
  10790.                   ) )
  10791.             ) ) )
  10792.             ht
  10793.         ) )
  10794.         (modified nil))
  10795.     ; Dann ⁿber die m÷glichen Codeenden iterieren:
  10796.     (maphash
  10797.       #'(lambda (code-beginning indices)
  10798.           (declare (ignore code-beginning))
  10799.           (when (cdr indices) ; mindestens zwei Indizes mit diesem Codeende?
  10800.             ; Versuche, m÷glichst langes Codestⁿck zusammenzulegen:
  10801.             (let ((codes ; Liste der zusammenzulegenden Codestⁿcke
  10802.                     (mapcar #'(lambda (i) (aref *code-parts* i)) indices)
  10803.                   )
  10804.                   (new-code '()) ; hier wird der gemeinsame Code gesammelt
  10805.                   (new-index (fill-pointer *code-parts*)) ; Index dafⁿr
  10806.                   (new-order ; das gemeinsame Stⁿck wird beim letzten Teil einzusortiert
  10807.                     (reduce #'max (mapcar #'(lambda (i) (aref *code-positions* i)) indices))
  10808.                  ))
  10809.               (loop
  10810.                 ; stimmen noch alle ⁿberein?
  10811.                 (unless (every #'consp codes) (return))
  10812.                 (let* ((code1 (first codes)) ; ein beliebiges der Codestⁿcke
  10813.                        (code11 (car code1))) ; dessen letzte Operation
  10814.                   (unless (every #'(lambda (code) (equal (car code) code11))
  10815.                                  (rest codes)
  10816.                           )
  10817.                     (return)
  10818.                   )
  10819.                   ; ja. Alle Codestⁿcke aus codes um eine Operation verkⁿrzen:
  10820.                   (mapc #'(lambda (code index) ; Referenzen l÷schen
  10821.                             (remove-references (car code) index)
  10822.                           )
  10823.                         codes indices
  10824.                   )
  10825.                   ; verkⁿrzen: (setq codes (mapcar #'cdr codes)), oder:
  10826.                   (mapl #'(lambda (codesr)
  10827.                             (setf (car codesr) (cdr (car codesr)))
  10828.                           )
  10829.                         codes
  10830.                   )
  10831.                   (push code11 new-code) ; new-code verlΣngern
  10832.                   (note-references code11 new-index)
  10833.               ) )
  10834.               (let* ((new-label (make-label 'ALL))
  10835.                      ; Alle Codestⁿcke aus codes wurden verkⁿrzt, sie werden
  10836.                      ; jetzt verlΣngert um ein (JMP new-label NIL).
  10837.                      (jmpop `(JMP ,new-label NIL)))
  10838.                 (mapc #'(lambda (code index)
  10839.                           (setf (aref *code-parts* index) (cons jmpop code))
  10840.                         )
  10841.                       codes indices
  10842.                 )
  10843.                 (setf (symbol-value new-label) indices) ; Referenzen auf new-label
  10844.                 (setf (get new-label 'code-part) new-index)
  10845.                 (vector-push-extend (nreconc new-code new-label) *code-parts*)
  10846.                 (vector-push-extend new-order *code-positions*)
  10847.               )
  10848.               ; weitere m÷gliche Optimierungen:
  10849.               (optimize-part (aref *code-parts* new-index))
  10850.               (coalesce indices)
  10851.               (setq modified t) ; VerΣnderung hat stattgefunden
  10852.         ) ) )
  10853.       parts-ht
  10854.     )
  10855.     modified
  10856. ) )
  10857.  
  10858. ; Die Hauptfunktion des 3. Schritts:
  10859. ; Fⁿhrt alle Optimierungen durch, und fa▀t dann alle Codestⁿcke wieder zu
  10860. ; einer einzigen Codeliste zusammen und liefert diese.
  10861. (defun optimize-all ()
  10862.   ; Optimierungen:
  10863.   (loop
  10864.     ; Optimierungen aufrufen:
  10865.     ; Wird eine fⁿndig, so ruft sie auch gleich die Optimierungs-
  10866.     ; schritte auf, die sich dadurch ergeben k÷nnten. Daher brauchen
  10867.     ; sie hier nur einmal aufgefⁿhrt zu werden.
  10868.     ; Vorsicht hier: durch die Optimierungen k÷nnen *code-parts* und sein
  10869.     ; Inhalt sich v÷llig verΣndern.
  10870.     (do ((index 0 (1+ index)))
  10871.         ((eql index (fill-pointer *code-parts*)))
  10872.       (let ((code (aref *code-parts* index)))
  10873.         (when code
  10874.           (let* ((lastc (last code))
  10875.                  (label (cdr lastc)))
  10876.             (when label
  10877.               (unless (eql index (get label 'code-part))
  10878.                 (compiler-error 'optimize-all 'code-part)
  10879.             ) )
  10880.             (optimize-label label index code lastc)
  10881.       ) ) )
  10882.       (let ((code (aref *code-parts* index)))
  10883.         (when code
  10884.           (optimize-jmpcase index code)
  10885.       ) )
  10886.       (let ((code (aref *code-parts* index)))
  10887.         (when code
  10888.           (optimize-value index code)
  10889.       ) )
  10890.       (let ((code (aref *code-parts* index)))
  10891.         (when code
  10892.           (optimize-short index code)
  10893.     ) ) )
  10894.     (unless (coalesce) (return)) ; (coalesce) tat nichts -> fertig
  10895.   )
  10896.   ; Zu einer einzigen Codeliste zusammenfassen:
  10897.   ; (Dabei werden die Labels nun Listenelemente im Code statt nur NTHCDRs.)
  10898.   (let ((start-index 0)) ; Start-"Label" NIL beginnt Codestⁿck Nr. 0
  10899.     ; Erst jeweils ein Codestⁿck, das mit label anfΣngt, wenn m÷glich an ein
  10900.     ; Codestⁿck anhΣngen, das mit einem JMP oder JMPCASE/... zu label endet.
  10901.     (do ((index (fill-pointer *code-parts*)))
  10902.         ((eql (decf index) 0)) ; index durchlΣuft die Indizes von *code-parts*
  10903.                                ; von oben nach unten, ausgenommen start-index=0.
  10904.       (let ((code (aref *code-parts* index)))
  10905.         (when code
  10906.           (loop
  10907.             ; Betrachte das Label am Ende von code, im Codestⁿck Nr. index:
  10908.             (let* ((lastc (last code)) ; letztes Cons von code
  10909.                    (label (cdr lastc)) ; Label am Ende von code
  10910.                    (refs (symbol-value label)) ; Referenzen darauf
  10911.                    (pos (aref *code-positions* index)) ; Position von code
  10912.                    (jmp-ref nil) ; bisher beste gefundene JMP-Referenz auf label
  10913.                    (jmpcase-ref nil) ; bisher beste gefundene JMPCASE-Referenz auf label
  10914.                    (jmpcase1-ref nil)) ; bisher beste gefundene JMPCASE1-...-Referenz auf label
  10915.               (if (null label)
  10916.                 ; Das Start-Code-Stⁿck wurde umgehΣngt!
  10917.                 (progn
  10918.                   (setq start-index index)
  10919.                   (return) ; zum nΣchsten Index
  10920.                 )
  10921.                 (flet ((better (new-ref old-ref)
  10922.                          ; Eine Referenz new-ref ist "besser" als eine andere
  10923.                          ; old-ref, wenn sie nΣher dran ist. Dabei haben
  10924.                          ; VorwΣrtsreferenzen generell PrioritΣt gegenⁿber
  10925.                          ; RⁿckwΣrtsreferenzen.
  10926.                          (or (null old-ref) ; noch gar kein old-ref?
  10927.                              (let ((old-pos (aref *code-positions* old-ref))
  10928.                                    (new-pos (aref *code-positions* new-ref)))
  10929.                                (if (> old-pos pos) ; Habe bisher nur RⁿckwΣrtssprung?
  10930.                                  ; ja: new-pos ist besser, falls es
  10931.                                  ; < pos (VorwΣrtssprung) oder
  10932.                                  ; >=pos, <=old-pos (kⁿrzerer RⁿckwΣrtssprung) ist.
  10933.                                  (<= new-pos old-pos)
  10934.                                  ; nein: new-pos ist besser, falls es
  10935.                                  ; <=pos, >=old-pos (kⁿrzerer VorwΣrtssprung) ist.
  10936.                                  (<= old-pos new-pos pos)
  10937.                       )) )   ) )
  10938.                   (macrolet ((update (old-ref new-ref) ; zur Bestimmung des bisher Besten
  10939.                                `(when (better ,new-ref ,old-ref)
  10940.                                   (setq ,old-ref ,new-ref)
  10941.                                 )
  10942.                             ))
  10943.                     ; Bestimme die beste Referenz, an die das Codestⁿck
  10944.                     ; gehΣngt werden kann:
  10945.                     (dolist (refindex refs)
  10946.                       (when (and (integerp refindex)
  10947.                                  (not (eql refindex index)) ; nicht an sich selber hΣngen!
  10948.                             )
  10949.                         (let ((refcode1 (car (aref *code-parts* refindex))))
  10950.                           (case (first refcode1)
  10951.                             (JMP ; m÷gliches AnhΣngen an (JMP label ...)
  10952.                               (update jmp-ref refindex)
  10953.                             )
  10954.                             (JMPCASE ; m÷gliches AnhΣngen an (JMPCASE ... label ...)
  10955.                               (update jmpcase-ref refindex)
  10956.                             )
  10957.                             (JMPCASE1-TRUE ; m÷gliches AnhΣngen an (JMPCASE1-TRUE ... label)
  10958.                               (when (eq label (third refcode1))
  10959.                                 (update jmpcase1-ref refindex)
  10960.                             ) )
  10961.                             (JMPCASE1-FALSE ; m÷gliches AnhΣngen an (JMPCASE1-FALSE label ...)
  10962.                               (when (eq label (second refcode1))
  10963.                                 (update jmpcase1-ref refindex)
  10964.                             ) )
  10965.                     ) ) ) )
  10966.                     (cond (jmp-ref ; an (JMP label) anhΣngen
  10967.                             (setf (cdr lastc)
  10968.                                   (cons label (cdr (aref *code-parts* jmp-ref)))
  10969.                             )
  10970.                             (setf (aref *code-parts* jmp-ref) nil)
  10971.                             (setq code lastc)
  10972.                           )
  10973.                           (jmpcase1-ref
  10974.                             (let* ((refcode (aref *code-parts* jmpcase1-ref))
  10975.                                    (refcode1 (car refcode))
  10976.                                    (jmpop
  10977.                                      (if (eq label (second refcode1))
  10978.                                        `(JMPIFNOT1 ,(third refcode1))
  10979.                                        `(JMPIF1 ,(second refcode1))
  10980.                                   )) )
  10981.                               (setf (cdr lastc) (list* label jmpop (cdr refcode)))
  10982.                               (setf (aref *code-parts* jmpcase1-ref) nil)
  10983.                               (setq code lastc)
  10984.                           ) )
  10985.                           (jmpcase-ref
  10986.                             (let* ((refcode (aref *code-parts* jmpcase-ref))
  10987.                                    (refcode1 (car refcode))
  10988.                                    (for-value (or (get (second refcode1) 'for-value)
  10989.                                                   (get (third refcode1) 'for-value)
  10990.                                    )          )
  10991.                                    (jmpop
  10992.                                      (if (eq label (second refcode1))
  10993.                                        `(JMPIFNOT ,(third refcode1) ,for-value)
  10994.                                        `(JMPIF ,(second refcode1) ,for-value)
  10995.                                   )) )
  10996.                               (setf (cdr lastc) (list* label jmpop (cdr refcode)))
  10997.                               (setf (aref *code-parts* jmpcase-ref) nil)
  10998.                               (setq code lastc)
  10999.                           ) )
  11000.                           (t ; kein AnhΣngen m÷glich
  11001.                             (return) ; zum nΣchsten Index
  11002.           ) ) ) ) ) )     )
  11003.     ) ) )
  11004.     ; Sicherstellen, da▀ das Anfangs-Stⁿck auch an den Anfang kommt:
  11005.     ; (Das wⁿrde auch gehen, indem bei jeder der obigen AnhΣngungen
  11006.     ; ein (setf (aref *code-positions* index) (aref *code-positions* jmp..-ref))
  11007.     ; gemacht wⁿrde. Wieso tun wir das nicht??)
  11008.     (setf (aref *code-positions* start-index) 0)
  11009.     ; Codeliste zusammensetzen:
  11010.     (let ((code-parts (map 'list #'cons *code-parts* *code-positions*)))
  11011.       (setq code-parts (delete-if-not #'car code-parts)) ; code=nil bedeutet: gestrichen
  11012.       (setq code-parts (sort code-parts #'> :key #'cdr)) ; nach Reihenfolge sortieren
  11013.       ; Die Teile sind jetzt in der richtigen Ordnung, nur umgekehrt.
  11014.       (let ((codelist '()))
  11015.         (dolist (code-part code-parts)
  11016.           (let ((code (car code-part)))
  11017.             ; code an codelist anhΣngen, dabei aber den Wegsprung umwandeln:
  11018.             (let ((item (car code)))
  11019.               (case (first item)
  11020.                 (JMP (setf (car code) `(JMP ,(second item))))
  11021.                 (JMPCASE ; (JMPCASE true-label false-label)
  11022.                          ; --> (JMPIFNOT false-label fv) (JMP true-label)
  11023.                   (setq code
  11024.                     (list* `(JMP ,(second item))
  11025.                            `(JMPIFNOT ,(third item)
  11026.                                       ,(or (get (second item) 'for-value)
  11027.                                            (get (third item) 'for-value)
  11028.                                        )
  11029.                             )
  11030.                            (cdr code)
  11031.                 ) ) )
  11032.                 (JMPCASE1-TRUE ; (JMPCASE1-TRUE true-label false-label)
  11033.                                ; --> (JMPIF1 true-label) (JMP false-label)
  11034.                   (setq code
  11035.                     (list* `(JMP ,(third item))
  11036.                            `(JMPIF1 ,(second item))
  11037.                            (cdr code)
  11038.                 ) ) )
  11039.                 (JMPCASE1-FALSE ; (JMPCASE1-FALSE true-label false-label)
  11040.                                 ; --> (JMPIFNOT1 false-label) (JMP true-label)
  11041.                   (setq code
  11042.                     (list* `(JMP ,(second item))
  11043.                            `(JMPIFNOT1 ,(third item))
  11044.                            (cdr code)
  11045.             ) ) ) ) )
  11046.             ; Label zum Listenelement machen:
  11047.             (let ((lastc (last code)))
  11048.               (when (cdr lastc)
  11049.                 (setf (cdr lastc) (list (cdr lastc)))
  11050.             ) )
  11051.             ; Umdrehen und vor codelist hΣngen (deswegen wurde vorhin
  11052.             ; mit #'> statt #'< sortiert):
  11053.             (setq codelist (nreconc code codelist))
  11054.         ) )
  11055.         codelist
  11056. ) ) ) )
  11057.  
  11058. #|
  11059. ;; Debugging hints:
  11060. (in-package "SYSTEM")
  11061. (setq *print-circle* t)
  11062. (trace compile-to-lap)
  11063. (trace (traverse-anode :post-print *code-part*))
  11064. (trace (optimize-part    :pre-print *code-parts* :post-print *code-parts*)
  11065.        (optimize-label   :pre-print *code-parts* :post-print *code-parts*)
  11066.        (optimize-short   :pre-print *code-parts* :post-print *code-parts*)
  11067.        (optimize-jmpcase :pre-print *code-parts* :post-print *code-parts*)
  11068.        (optimize-value   :pre-print *code-parts* :post-print *code-parts*)
  11069.        (coalesce         :pre-print *code-parts* :post-print *code-parts*)
  11070.        (optimize-all     :pre-print *code-parts* :post-print *code-parts*)
  11071. )
  11072. (trace simplify)
  11073. ;; Move out suspect code to a separate file which you load interpreted.
  11074.  
  11075. ;; Special debugging checks:
  11076. (defun optimize-check ()
  11077.   (do ((index 0 (1+ index)))
  11078.       ((eql index (fill-pointer *code-parts*)))
  11079.     (let ((code (aref *code-parts* index)))
  11080.       (when code
  11081.         (let* ((lastc (last code))
  11082.                (label (cdr lastc)))
  11083.           (when label
  11084.             (unless (eql index (get label 'code-part))
  11085.               (compiler-error 'optimize-check 'code-part)
  11086. ) ) ) ) ) ) )
  11087. (trace
  11088.   (optimize-part    :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11089.   (optimize-label   :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11090.   (optimize-short   :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11091.   (optimize-jmpcase :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11092.   (optimize-value   :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11093.   (coalesce         :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11094.   (optimize-all     :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11095. )
  11096. |#
  11097.  
  11098. #| Was ist mit den folgenden m÷glichen Optimierungen??
  11099.  
  11100. 10. Kommt vor einem (JMP label) ein (UNWIND-PROTECT-CLEANUP) und vor dem
  11101.    label ein (UNWIND-PROTECT-3 cleanup-label), so mu▀ es sich um denselben
  11102.    UNWIND-PROTECT-Frame handeln, und man kann (UNWIND-PROTECT-CLEANUP)
  11103.    streichen und (JMP label) durch (JMP newlabel) ersetzen, wobei newlabel
  11104.    ein neues Label ist, das vor dem (evtl. zu ergΣnzenden) (UNWIND-PROTECT-2)
  11105.    vor cleanup-label sitzt:
  11106.    (UNWIND-PROTECT-CLEANUP) (JMP label) ...
  11107.    ... [(UNWIND-PROTECT-2)] cleanup-label ... (UNWIND-PROTECT-3 cleanup-label) label
  11108.    -->
  11109.    (JMP newlabel) ...
  11110.    ... newlabel (UNWIND-PROTECT-2) cleanup-label ... (UNWIND-PROTECT-3 cleanup-label) label
  11111.  
  11112. 11. Kommt nach einem Label label ein (NIL), so darf jeder (JMPIFNOT label)
  11113.    und jeder (JMPIFNOT1 label) durch ein (JMPIFNOT1 z) ersetzt werden,
  11114.    wo z ein neues Label nach dem (NIL) ist:
  11115.           (JMPIFNOT label) ... label (NIL) ...
  11116.    -->       (JMPIFNOT1 z) ... label (NIL) z ...
  11117.  
  11118. |#
  11119.  
  11120. ; Fⁿhrt den 1. und 2.,3. Schritt aus:
  11121. (defun compile-to-LAP ()
  11122.   (let ((*code-parts* (make-array 10 :adjustable t :fill-pointer 0))
  11123.         (*code-positions* (make-array 10 :adjustable t :fill-pointer 0)))
  11124.     ; Expandiert den Code des Fnode *func* und teilt ihn in Stⁿcke auf.
  11125.     ; HinterlΣ▀t seine Werte in *code-parts* und *code-positions*.
  11126.     (let ((*code-part* (list '(START))) ; NIL als Start-"Label"
  11127.           (*code-index* 0)
  11128.           (*dead-code* nil)
  11129.           (*label-subst* '())
  11130.           (*current-value* nil)
  11131.           (*current-vars* '()))
  11132.       (traverse-anode (anode-code (fnode-code *func*)))
  11133.     )
  11134.     ; Optimiert in *code-parts* und *code-positions*, fa▀t dann den Code
  11135.     ; in einer Liste zusammen und liefert diese:
  11136.     (let ((code-list (optimize-all)))
  11137.       (unless (equal (pop code-list) '(START))
  11138.         (compiler-error 'compile-to-LAP 'start)
  11139.       )
  11140.       code-list
  11141. ) ) )
  11142.  
  11143.  
  11144. #|
  11145.                             4. Schritt:
  11146.                       Eliminieren von (CONST n)
  11147.  
  11148. Generische Funktionen haben eine feste LΣnge. Die Konstanten werden im
  11149. VENV-Const aufbewahrt. In diesem Schritt werden umgewandelt:
  11150.   (LOADV k m)    -->  (LOADV k+1 m)
  11151.   (STOREV k m)   -->  (STOREV k+1 m)
  11152.   (CONST n [c])  -->  (LOADV 0 n)
  11153.   (VENV)         -->  (LOADV 0 0)
  11154.   (JMPHASH n ht label . labels)  -->  (JMPHASHV n ht label . labels)
  11155.   (GETVALUE n)         -->  illegal
  11156.   (SETVALUE n)         -->  illegal
  11157.   (BIND n)             -->  illegal
  11158.   (COPY-CLOSURE m n)   -->  illegal
  11159.   (CALL k n)           -->  illegal
  11160.   (CALL0 n)            -->  illegal
  11161.   (CALL1 n)            -->  illegal
  11162.   (CALL2 n)            -->  illegal
  11163.   (BLOCK-OPEN n label) -->  illegal
  11164.   (RETURN-FROM n)      -->  illegal
  11165.   (TAGBODY-OPEN n ...) -->  illegal
  11166.   (GO n l)             -->  illegal
  11167. |#
  11168.  
  11169. (defun CONST-to-LOADV (code-list)
  11170.   (do ((codelistr code-list (cdr codelistr)))
  11171.       ((null codelistr))
  11172.     (let ((item (car codelistr)))
  11173.       (when (consp item)
  11174.         (case (first item)
  11175.           ((LOADV STOREV)
  11176.             (setf (car codelistr)
  11177.                   `(,(first item) ,(1+ (second item)) ,@(cddr item))
  11178.           ) )
  11179.           (CONST
  11180.             (setf (car codelistr) `(LOADV 0 ,(second item)))
  11181.           )
  11182.           (VENV
  11183.             (setf (car codelistr) `(LOADV 0 0))
  11184.           )
  11185.           (JMPHASH
  11186.             (setf (car codelistr) `(JMPHASHV ,@(cdr item)))
  11187.           )
  11188.           ((GETVALUE SETVALUE BIND COPY-CLOSURE CALL CALL0 CALL1 CALL2
  11189.             BLOCK-OPEN RETURN-FROM TAGBODY-OPEN GO)
  11190.             (compiler-error 'CONST-to-LOADV "Illegal-in-GF")
  11191.           )
  11192.   ) ) ) )
  11193.   code-list
  11194. )
  11195.  
  11196.  
  11197. #|
  11198.                             5. Schritt:
  11199.                    Bestimmung des Stackbedarfs
  11200.  
  11201. Dieser Schritt bestimmt, wieviel SP-EintrΣge die Funktion maximal braucht.
  11202. |#
  11203.  
  11204. (defun SP-depth (code-list)
  11205.   (let ((max-depth-1 0) (max-depth-2 0) ; bisherige Maximal-Tiefe
  11206.         (unseen-label-alist '()) ; Labels, ab denen noch verfolgt werden mu▀
  11207.         (seen-label-alist '()) ; Labels, die schon verfolgt wurden
  11208.           ; beides Alisten ((label depth ...) ...)
  11209.           ; Es ist durchaus m÷glich, da▀ dasselbe Codestⁿck mit unterschied-
  11210.           ; lichen SP-Tiefen durchgefⁿhrt werden kann (nΣmlich dann, wenn es
  11211.           ; mit einem Wegsprung THROW, RETURN-FROM, RETURN-FROM-I, GO, GO-I
  11212.           ; oder BARRIER endet)!
  11213.           ; seen-label-alist enthΣlt zu jedem Label die maximale Tiefe, mit
  11214.           ; der ab diesem Label schon verfolgt wurde.
  11215.           ; unsee-label-alist enthΣlt zu jedem Label die maximale bisher
  11216.           ; notierte Tiefe, mit der ab diesem Label noch verfolgt werden mu▀.
  11217.         (mitte code-list) ; restliche Codeliste
  11218.         (depth (spd 0 0)) ; aktuelle Tiefe
  11219.        )
  11220.     (macrolet ((check-depth (wanted-depth)
  11221.                  ; ⁿberprⁿft, ob depth gleich der Tiefe wanted-depth ist
  11222.                  `(unless (equal depth ,wanted-depth)
  11223.                     (compiler-error 'SP-depth)
  11224.                   )
  11225.               ))
  11226.       (loop
  11227.         ; mitte lΣuft durch die Codeliste, von der aktuellen Position
  11228.         ; bis zum nΣchsten Wegsprung, und zΣhlt die Tiefe mit.
  11229.         (loop
  11230.           (when (null mitte) (return))
  11231.           (let ((item (car mitte)))
  11232.             (if (atom item)
  11233.               ; Label
  11234.               (let ((h (assoc item seen-label-alist)))
  11235.                 (if h
  11236.                   (if (some-spd<= depth (cdr h))
  11237.                     (return)
  11238.                     (push depth (cdr h))
  11239.                   )
  11240.                   (push (list item depth) seen-label-alist)
  11241.               ) )
  11242.               ; Instruktion
  11243.               (macrolet ((note-label (labelform)
  11244.                            ; notiere, da▀ zu label gesprungen werden kann
  11245.                            (let ((label (gensym)))
  11246.                              `(let* ((,label ,labelform)
  11247.                                      (h (assoc ,label seen-label-alist)))
  11248.                                 (unless (and h (some-spd<= depth (cdr h)))
  11249.                                   (setq h (assoc ,label unseen-label-alist))
  11250.                                   (if h
  11251.                                     (unless (some-spd<= depth (cdr h))
  11252.                                       (push depth (cdr h))
  11253.                                     )
  11254.                                     (push (list ,label depth) unseen-label-alist)
  11255.                               ) ) )
  11256.                          ) )
  11257.                          (note-inc (amount)
  11258.                            ; notiere, da▀ depth um amount erh÷ht wird
  11259.                            `(progn
  11260.                               (setq depth (spd+ depth ,amount))
  11261.                               (setq max-depth-1 (max max-depth-1 (car depth)))
  11262.                               (setq max-depth-2 (max max-depth-2 (cdr depth)))
  11263.                             )
  11264.                          )
  11265.                          (note-dec (amount)
  11266.                            ; notiere, da▀ depth um amount erniedrigt wird
  11267.                            `(progn
  11268.                               (setq depth (spd- depth ,amount))
  11269.                               (when (or (minusp (car depth)) (minusp (cdr depth)))
  11270.                                 (compiler-error 'SP-depth "<0")
  11271.                             ) )
  11272.                          )
  11273.                          (note-jmp ()
  11274.                            ; notiere, da▀ weggesprungen wird
  11275.                            `(return)
  11276.                         ))
  11277.                 (case (first item)
  11278.                   (JMP ; (JMP label)
  11279.                     (note-label (second item))
  11280.                     (note-jmp)
  11281.                   )
  11282.                   ((JMPIF JMPIF1 JMPIFNOT JMPIFNOT1 JMPIFBOUNDP) ; (JMP... label)
  11283.                     (note-label (second item))
  11284.                   )
  11285.                   ((JMPHASH JMPHASHV JMPTAIL) ; (JMPHASH.. n ht label . labels), (JMPTAIL m n label)
  11286.                     (dolist (label (cdddr item)) (note-label label))
  11287.                     (note-jmp)
  11288.                   )
  11289.                   (JSR ; (JSR n label)
  11290.                     (let ((depth (spd 0 0))) (note-label (third item)))
  11291.                   )
  11292.                   ((BARRIER THROW RETURN-FROM RETURN-FROM-I GO GO-I) ; (BARRIER), (THROW), (RETURN-FROM n), (RETURN-FROM-I k n), (GO n l), (GO-I k n l)
  11293.                     (note-jmp)
  11294.                   )
  11295.                   (RET ; (RET)
  11296.                     (check-depth (spd 0 0))
  11297.                     (note-jmp)
  11298.                   )
  11299.                   (PROGV ; (PROGV)
  11300.                     (note-inc (spd 1 0))
  11301.                   )
  11302.                   (CATCH-OPEN ; (CATCH-OPEN label)
  11303.                     (note-label (second item))
  11304.                     (note-inc (spd 2 1))
  11305.                   )
  11306.                   (CATCH-CLOSE ; (CATCH-CLOSE)
  11307.                     (note-dec (spd 2 1))
  11308.                   )
  11309.                   (UNWIND-PROTECT-OPEN ; (UNWIND-PROTECT-OPEN label)
  11310.                     ; eigentlich: (note-inc (spd 2 1))
  11311.                     (note-inc (spd 3 0)) (note-label (second item)) (note-dec (spd 3 0))
  11312.                     (note-inc (spd 2 1))
  11313.                   )
  11314.                   (UNWIND-PROTECT-NORMAL-EXIT ; (UNWIND-PROTECT-NORMAL-EXIT), danach kommt label
  11315.                     (note-dec (spd 2 1)) (note-inc (spd 3 0))
  11316.                   )
  11317.                   (UNWIND-PROTECT-CLOSE ; (UNWIND-PROTECT-CLOSE label)
  11318.                     ; eigentlich: (note-dec (spd 3 0))
  11319.                     (note-label (second item)) (note-dec (spd 3 0))
  11320.                   )
  11321.                   (UNWIND-PROTECT-CLEANUP ; (UNWIND-PROTECT-CLEANUP)
  11322.                     ; eigentlich: (note-dec (spd 2 1)) (note-inc (spd 3 0)) ... (note-dec (spd 3 0))
  11323.                     (note-dec (spd 2 1))
  11324.                   )
  11325.                   (BLOCK-OPEN ; (BLOCK-OPEN n label)
  11326.                     (note-label (third item))
  11327.                     (note-inc (spd 2 1))
  11328.                   )
  11329.                   (BLOCK-CLOSE ; (BLOCK-CLOSE)
  11330.                     (note-dec (spd 2 1))
  11331.                   )
  11332.                   (TAGBODY-OPEN ; (TAGBODY-OPEN n label1 ... labelm)
  11333.                     (note-inc (spd 1 1))
  11334.                     (dolist (label (cddr item)) (note-label label))
  11335.                   )
  11336.                   ((TAGBODY-CLOSE-NIL TAGBODY-CLOSE) ; (TAGBODY-CLOSE-NIL), (TAGBODY-CLOSE)
  11337.                     (note-dec (spd 1 1))
  11338.                   )
  11339.                   (HANDLER-OPEN ; (HANDLER-OPEN n v k label1 ... labelm)
  11340.                     (check-depth (fourth item))
  11341.                     (dolist (label (cddddr item)) (note-label label))
  11342.                   )
  11343.                   ((MVCALLP HANDLER-BEGIN) ; (MVCALLP), (HANDLER-BEGIN)
  11344.                     (note-inc (spd 1 0))
  11345.                   )
  11346.                   (MVCALL ; (MVCALL)
  11347.                     (note-dec (spd 1 0))
  11348.                   )
  11349.                   (SKIPSP ; (SKIPSP k1 k2)
  11350.                     (note-dec (spd (second item) (third item)))
  11351.                   )
  11352.                   (SKIPI ; (SKIPI k1 k2 n)
  11353.                     (note-dec (spd (+ (second item) 1) (third item)))
  11354.                   )
  11355.               ) )
  11356.           ) )
  11357.           (setq mitte (cdr mitte))
  11358.         )
  11359.         ; NΣchstes zu verfolgendes Label suchen:
  11360.         (loop
  11361.           (when (null unseen-label-alist) ; fertig ?
  11362.             (return-from SP-depth (spd max-depth-1 max-depth-2))
  11363.           )
  11364.           (let* ((unseen (car unseen-label-alist))
  11365.                  (label (car unseen))) ; nΣchstes zu verfolgendes Label
  11366.             (setq depth (pop (cdr unseen)))
  11367.             (when (null (cdr unseen))
  11368.               (setq unseen-label-alist (cdr unseen-label-alist))
  11369.             )
  11370.             (let ((h (assoc label seen-label-alist)))
  11371.               (unless (and h (some-spd<= depth (cdr h)))
  11372.                 ; Ab diesem Label die Codeliste abarbeiten:
  11373.                 ; (Dadurch wird (label . depth) in seen-label-alist aufgenommen,
  11374.                 ; es ist bereits aus unseen-label-alist entfernt.)
  11375.                 (setq mitte (member label code-list :test #'eq))
  11376.                 (return)
  11377.         ) ) ) )
  11378. ) ) ) )
  11379.  
  11380.  
  11381. #|
  11382.                             6. Schritt:
  11383.                  Einfⁿhrung von Kurz-Operationen
  11384.  
  11385. Dieser Schritt arbeitet auf der Codeliste und verΣndert sie dabei destruktiv.
  11386.  
  11387. 1. (ATOM) (JMPIF label NIL)             --> (JMPIFATOM label)
  11388.    (ATOM) (JMPIFNOT label NIL)          --> (JMPIFCONSP label)
  11389.    (CONSP) (JMPIF label NIL)            --> (JMPIFCONSP label)
  11390.    (CONSP) (JMPIFNOT label NIL)         --> (JMPIFATOM label)
  11391.    (ATOM)                               --> (PUSH) (CALLS ATOM)
  11392.    (CONSP)                              --> (PUSH) (CALLS CONSP)
  11393.  
  11394. 2. (NIL) (PUSH)                         --> (NIL&PUSH)
  11395.    (NIL) (PUSH) ... (NIL) (PUSH)        --> (PUSH-NIL n)
  11396.    (NIL) (STORE n)                      --> (NIL&STORE n)
  11397.    (PUSH-NIL 1)                         --> (NIL&PUSH)
  11398.  
  11399. 3. (T) (PUSH)                           --> (T&PUSH)
  11400.    (T) (STORE n)                        --> (T&STORE n)
  11401.  
  11402. 4. (CONST n c)                          --> (CONST n)
  11403.    (CONST n) (PUSH)                     --> (CONST&PUSH n)
  11404.    (CONST n) (SYMBOL-FUNCTION) (PUSH)   --> (CONST&SYMBOL-FUNCTION&PUSH n)
  11405.    (CONST n) (SYMBOL-FUNCTION) (STORE m)--> (CONST&SYMBOL-FUNCTION&STORE n m)
  11406.    (CONST n) (SYMBOL-FUNCTION)          --> (CONST&SYMBOL-FUNCTION n)
  11407.  
  11408. 5. (COPY-CLOSURE n m) (PUSH)            --> (COPY-CLOSURE&PUSH n m)
  11409.  
  11410. 6. (LOAD n) (PUSH)                      --> (LOAD&PUSH n)
  11411.    (LOAD k) (STOREC n m)                --> (LOAD&STOREC k n m)
  11412.    (LOAD n) (JMPIF label fv)            --> (LOAD&JMPIF n label)
  11413.    (LOAD n) (JMPIFNOT label fv)         --> (LOAD&JMPIFNOT n label)
  11414.    (LOAD n) (CAR) (PUSH)                --> (LOAD&CAR&PUSH n)
  11415.    (LOAD n) (CDR) (PUSH)                --> (LOAD&CDR&PUSH n)
  11416.    (LOAD n) (CDR) (STORE n)             --> (LOAD&CDR&STORE n)
  11417.    (LOAD n+1) (CONS) (STORE n)          --> (LOAD&CONS&STORE n)
  11418.    (LOAD n) (PUSH) (CALLS 1+) (STORE n) --> (LOAD&INC&STORE n)
  11419.    (LOAD n) (PUSH) (CALLS 1-) (STORE n) --> (LOAD&DEC&STORE n)
  11420.    (LOAD n) (PUSH) (CALLS 1+) (PUSH)    --> (LOAD&INC&PUSH n)
  11421.    (LOAD n) (PUSH) (CALLS 1-) (PUSH)    --> (LOAD&DEC&PUSH n)
  11422.    (LOAD n) (CAR) (STORE m)             --> (LOAD&CAR&STORE n m)
  11423.  
  11424. 7. (JMPIFBOUNDP n l) (NIL) (STORE n) l  --> (UNBOUND->NIL n) l
  11425.  
  11426. 8. (LOADI n1 n2 n3) (PUSH)              --> (LOADI&PUSH n1 n2 n3)
  11427.    (LOADC n1 n2) (PUSH)                 --> (LOADC&PUSH n1 n2)
  11428.    (LOADV n1 n2) (PUSH)                 --> (LOADV&PUSH n1 n2)
  11429.  
  11430. 9. (GETVALUE n) (PUSH)                  --> (GETVALUE&PUSH n)
  11431.  
  11432. 10. (UNBIND1) ... (UNBIND1)             --> (UNBIND n)
  11433.  
  11434. 11. (CAR) (PUSH)                        --> (CAR&PUSH)
  11435.     (CDR) (PUSH)                        --> (CDR&PUSH)
  11436.     (CONS) (PUSH)                       --> (CONS&PUSH)
  11437.     (LIST n) (PUSH)                     --> (LIST&PUSH n)
  11438.     (LIST* n) (PUSH)                    --> (LIST*&PUSH n)
  11439.     (FUNCALL n) (PUS)                   --> (FUNCALL&PUSH n)
  11440.     (APPLY n) (PUSH)                    --> (APPLY&PUSH n)
  11441.  
  11442. 12. (POP) (STORE n)                      --> (POP&STORE n)
  11443.  
  11444. 13. (SKIP n) (RET)                      --> (SKIP&RET n)
  11445.     ; (RET)                             --> (SKIP&RET 0)
  11446.     ; kommt nicht vor, da im Stack stets noch die Closure selbst sitzt
  11447.  
  11448. 14. (UNWIND-PROTECT-CLOSE label)        --> (UNWIND-PROTECT-CLOSE)
  11449.  
  11450. 15. (JMPHASH n ht label . labels)       --> (JMPHASH n ht label)
  11451.     (JMPHASHV n ht label . labels)      --> (JMPHASHV n ht label)
  11452.  
  11453. 16. (JSR n label)                       --> (JSR label)
  11454.     (JSR n label) (PUSH)                --> (JSR&PUSH label)
  11455.  
  11456. 17. (CALL m n) (PUSH)                   --> (CALL&PUSH m n)
  11457.     (CALL1 n) (PUSH)                    --> (CALL1&PUSH n)
  11458.     (CALL2 n) (PUSH)                    --> (CALL2&PUSH n)
  11459.     (CALLS1 n) (PUSH)                   --> (CALLS1&PUSH n)
  11460.     (CALLS2 n) (PUSH)                   --> (CALLS2&PUSH n)
  11461.     (CALLSR m n) (PUSH)                 --> (CALLSR&PUSH m n)
  11462.     (CALLC) (PUSH)                      --> (CALLC&PUSH)
  11463.     (CALLCKEY) (PUSH)                   --> (CALLCKEY&PUSH)
  11464.  
  11465. 18. (CALL1 n) (JMPIF label fv)          --> (CALL1&JMPIF n label)
  11466.     (CALL1 n) (JMPIFNOT label fv)       --> (CALL1&JMPIFNOT n label)
  11467.     (CALL2 n) (JMPIF label fv)          --> (CALL2&JMPIF n label)
  11468.     (CALL2 n) (JMPIFNOT label fv)       --> (CALL2&JMPIFNOT n label)
  11469.     (CALLS1 n) (JMPIF label fv)         --> (CALLS1&JMPIF n label)
  11470.     (CALLS1 n) (JMPIFNOT label fv)      --> (CALLS1&JMPIFNOT n label)
  11471.     (CALLS2 n) (JMPIF label fv)         --> (CALLS2&JMPIF n label)
  11472.     (CALLS2 n) (JMPIFNOT label fv)      --> (CALLS2&JMPIFNOT n label)
  11473.     (CALLSR m n) (JMPIF label fv)       --> (CALLSR&JMPIF m n label)
  11474.     (CALLSR m n) (JMPIFNOT label fv)    --> (CALLSR&JMPIFNOT m n label)
  11475.  
  11476. 19. (CALLS1 n) (STORE k)                --> (CALLS1&STORE n k)
  11477.     (CALLS2 n) (STORE k)                --> (CALLS2&STORE n k)
  11478.     (CALLSR m n) (STORE k)              --> (CALLSR&STORE m n k)
  11479.  
  11480. 20. (EQ) (JMPIF label NIL)              --> (JMPIFEQ label)
  11481.     (EQ) (JMPIFNOT label NIL)           --> (JMPIFNOTEQ label)
  11482.     (CONST n) (EQ) (JMPIF label NIL)    --> (JMPIFEQTO n label)
  11483.     (CONST n) (EQ) (JMPIFNOT label NIL) --> (JMPIFNOTEQTO n label)
  11484.  
  11485. 21. (APPLY n) (SKIP k) (RET)            --> (APPLY&SKIP&RET n k)
  11486.  
  11487. 22. (HANDLER-BEGIN) (PUSH)              --> (HANDLER-BEGIN&PUSH)
  11488.  
  11489. 23. (BARRIER)                           -->
  11490.  
  11491. |#
  11492.  
  11493. (let ((CALLS-1+ (CALLS-code (gethash '1+ function-codes)))
  11494.       (CALLS-1- (CALLS-code (gethash '1- function-codes)))
  11495.       (CALLS-atom (CALLS-code (gethash 'atom function-codes)))
  11496.       (CALLS-consp (CALLS-code (gethash 'consp function-codes))))
  11497.   (defun insert-combined-LAPs (code-list)
  11498.     ; ZunΣchst die ATOM/CONSP-Umwandlung, weil diese PUSHs einfⁿhren kann:
  11499.     (do ((crest code-list (cdr crest)))
  11500.         ((null crest))
  11501.       (let ((item (car crest)))
  11502.         (when (consp item)
  11503.           (case (first item)
  11504.             (CONST ; (CONST n c) -> (CONST n)
  11505.               (setf (cddr item) '())
  11506.             )
  11507.             ((ATOM CONSP)
  11508.               (setq item (first item))
  11509.               (if (and #| (consp (cdr crest)) |#
  11510.                        (consp (cadr crest))
  11511.                        (memq (first (cadr crest)) '(JMPIF JMPIFNOT))
  11512.                        (null (third (cadr crest)))
  11513.                   )
  11514.                 ; z.B. (ATOM) (JMPIF label NIL) --> (JMPIFATOM label)
  11515.                 (setf (car crest)
  11516.                       `(,(if (eq (first (cadr crest)) 'JMPIF)
  11517.                            (if (eq item 'ATOM) 'JMPIFATOM 'JMPIFCONSP)
  11518.                            (if (eq item 'ATOM) 'JMPIFCONSP 'JMPIFATOM)
  11519.                          )
  11520.                         ,(second (cadr crest))
  11521.                        )
  11522.                       (cdr crest) (cddr crest)
  11523.                 )
  11524.                 ; z.B. (ATOM) --> (PUSH) (CALLS ATOM)
  11525.                 (setf (car crest) '(PUSH)
  11526.                       (cdr crest) (cons (if (eq item 'ATOM) CALLS-atom CALLS-consp)
  11527.                                         (cdr crest)
  11528.                 )                 )
  11529.     ) ) ) ) ) )
  11530.     ; Nun die sonstigen Umformungen: Ein einziger Durchlauf.
  11531.     ; Zwei Pointer laufen durch die Codeliste: ...mitte.rechts...
  11532.     (do* ((mitte code-list rechts)
  11533.           (rechts (cdr mitte) (cdr rechts)))
  11534.          ((null mitte))
  11535.       (macrolet ((ersetze (length new-code)
  11536.                    ; ersetzt die nΣchsten length Elemente
  11537.                    ; (nth 0 mitte) ... (nth (- length 1) mitte)
  11538.                    ; durch ein einziges Element new-code.
  11539.                    (assert (typep length '(INTEGER 0 4)))
  11540.                    `(progn
  11541.                       ,(case length
  11542.                          (0 `(setf (cdr mitte) (setq rechts (cons (car mitte) rechts))
  11543.                                    (car mitte) ,new-code
  11544.                          )   )
  11545.                          (1 `(setf (car mitte) ,new-code))
  11546.                          (t `(setf (car mitte) ,new-code
  11547.                                    (cdr mitte) ,(setq rechts
  11548.                                                   (case length
  11549.                                                     (2 `(cdr rechts))
  11550.                                                     (3 `(cddr rechts))
  11551.                                                     (4 `(cdddr rechts))
  11552.                                                 ) )
  11553.                        ) )   )
  11554.                       (go weiter)
  11555.                     )
  11556.                 ))
  11557.         (let ((item (car mitte)))
  11558.           (when (consp item)
  11559.             ; Untersuchung des Befehls item und der nachfolgenden:
  11560.             (when (and #| (consp rechts) |# (consp (car rechts)))
  11561.               ; normale Umwandlungen, mit AneinanderhΣngen der Argumente:
  11562.               (let ((new-op
  11563.                       (cdr (assoc (first item)
  11564.                                   (case (first (car rechts))
  11565.                                     (PUSH  '((T        . T&PUSH)
  11566.                                              (CONST    . CONST&PUSH)
  11567.                                              (LOADI    . LOADI&PUSH)
  11568.                                              (LOADC    . LOADC&PUSH)
  11569.                                              (LOADV    . LOADV&PUSH)
  11570.                                              (GETVALUE . GETVALUE&PUSH)
  11571.                                              (CALL     . CALL&PUSH)
  11572.                                              (CALL1    . CALL1&PUSH)
  11573.                                              (CALL2    . CALL2&PUSH)
  11574.                                              (CALLS1   . CALLS1&PUSH)
  11575.                                              (CALLS2   . CALLS2&PUSH)
  11576.                                              (CALLSR   . CALLSR&PUSH)
  11577.                                              (CALLC    . CALLC&PUSH)
  11578.                                              (CALLCKEY . CALLCKEY&PUSH)
  11579.                                              (CAR      . CAR&PUSH)
  11580.                                              (CDR      . CDR&PUSH)
  11581.                                              (CONS     . CONS&PUSH)
  11582.                                              (LIST     . LIST&PUSH)
  11583.                                              (LIST*    . LIST*&PUSH)
  11584.                                              (FUNCALL  . FUNCALL&PUSH)
  11585.                                              (APPLY    . APPLY&PUSH)
  11586.                                              (COPY-CLOSURE . COPY-CLOSURE&PUSH)
  11587.                                              (HANDLER-BEGIN . HANDLER-BEGIN&PUSH)
  11588.                                     )       )
  11589.                                     (JMPIF
  11590.                                       (let ((alist
  11591.                                               '((EQ     . JMPIFEQ)
  11592.                                                 (LOAD   . LOAD&JMPIF)
  11593.                                                 (CALL1  . CALL1&JMPIF)
  11594.                                                 (CALL2  . CALL2&JMPIF)
  11595.                                                 (CALLS1 . CALLS1&JMPIF)
  11596.                                                 (CALLS2 . CALLS2&JMPIF)
  11597.                                                 (CALLSR . CALLSR&JMPIF)
  11598.                                                )
  11599.                                            ))
  11600.                                         (when (third (car rechts))
  11601.                                           (setq alist (cdr alist))
  11602.                                         )
  11603.                                         (setf (cddr (car rechts)) '())
  11604.                                         alist
  11605.                                     ) )
  11606.                                     (JMPIFNOT
  11607.                                       (let ((alist
  11608.                                               '((EQ     . JMPIFNOTEQ)
  11609.                                                 (LOAD   . LOAD&JMPIFNOT)
  11610.                                                 (CALL1  . CALL1&JMPIFNOT)
  11611.                                                 (CALL2  . CALL2&JMPIFNOT)
  11612.                                                 (CALLS1 . CALLS1&JMPIFNOT)
  11613.                                                 (CALLS2 . CALLS2&JMPIFNOT)
  11614.                                                 (CALLSR . CALLSR&JMPIFNOT)
  11615.                                                )
  11616.                                            ))
  11617.                                         (when (third (car rechts))
  11618.                                           (setq alist (cdr alist))
  11619.                                         )
  11620.                                         (setf (cddr (car rechts)) '())
  11621.                                         alist
  11622.                                     ) )
  11623.                                     (STORE '((NIL    . NIL&STORE)
  11624.                                              (T      . T&STORE)
  11625.                                              (POP    . POP&STORE)
  11626.                                              (CALLS1 . CALLS1&STORE)
  11627.                                              (CALLS2 . CALLS2&STORE)
  11628.                                              (CALLSR . CALLSR&STORE)
  11629.                                     )       )
  11630.                                     (STOREC '((LOAD . LOAD&STOREC)))
  11631.                                     (RET '((SKIP . SKIP&RET)))
  11632.                                   )
  11633.                                   :test #'eq
  11634.                    )) )    )
  11635.                 (when new-op
  11636.                   (ersetze 2 `(,new-op ,@(rest item) ,@(rest (car rechts))))
  11637.             ) ) )
  11638.             ; weitere Umwandlungen:
  11639.             (case (first item)
  11640.               ((NIL PUSH-NIL)
  11641.                 (flet ((nilpusher-p (coder)
  11642.                          ; Kommt (NIL) (PUSH) --> 1,
  11643.                          ; kommt (PUSH-NIL n) --> n,
  11644.                          ; sonst nil.
  11645.                          (and #| (consp coder) |# (consp (car coder))
  11646.                               (case (first (car coder))
  11647.                                 (PUSH-NIL (second (car coder)))
  11648.                                 ((NIL) (when (equal (cadr coder) '(PUSH))
  11649.                                          (setf (cdr coder) (cddr coder))
  11650.                                          1
  11651.                                 )      )
  11652.                                 (t nil)
  11653.                       )) )    )
  11654.                   (let ((count (nilpusher-p mitte)))
  11655.                     (when count
  11656.                       (setq rechts (cdr mitte))
  11657.                       (loop
  11658.                         (let ((next-count (nilpusher-p rechts)))
  11659.                           (unless next-count (return))
  11660.                           (incf count next-count)
  11661.                         )
  11662.                         (setq rechts (cdr rechts))
  11663.                       )
  11664.                       (setf (car mitte) (if (eql count 1) '(NIL&PUSH) `(PUSH-NIL ,count))
  11665.                             (cdr mitte) rechts
  11666.                       )
  11667.                       (go weiter)
  11668.               ) ) ) )
  11669.               (CONST
  11670.                 (when (and #| (consp rechts) |# (consp (car rechts)))
  11671.                   (case (first (car rechts))
  11672.                     (SYMBOL-FUNCTION
  11673.                       (let ((n (second item)))
  11674.                         (cond ((and #| (consp (cdr rechts)) |#
  11675.                                     (equal (cadr rechts) '(PUSH))
  11676.                                )
  11677.                                (ersetze 3 `(CONST&SYMBOL-FUNCTION&PUSH ,n))
  11678.                               )
  11679.                               ((and #| (consp (cdr rechts)) |#
  11680.                                     (consp (cadr rechts))
  11681.                                     (eq (first (cadr rechts)) 'STORE)
  11682.                                )
  11683.                                (ersetze 3
  11684.                                  `(CONST&SYMBOL-FUNCTION&STORE ,n ,(second (cadr rechts)))
  11685.                               ))
  11686.                               (t (ersetze 2 `(CONST&SYMBOL-FUNCTION ,n)))
  11687.                     ) ) )
  11688.                     (EQ
  11689.                       (when (and #| (consp (cdr rechts)) |#
  11690.                                  (consp (cadr rechts))
  11691.                                  (memq (first (cadr rechts)) '(JMPIF JMPIFNOT))
  11692.                                  (null (third (cadr rechts)))
  11693.                             )
  11694.                         (ersetze 3
  11695.                           `(,(if (eq (first (cadr rechts)) 'JMPIF)
  11696.                                'JMPIFEQTO
  11697.                                'JMPIFNOTEQTO
  11698.                              )
  11699.                             ,(second item)
  11700.                             ,(second (cadr rechts))
  11701.                            )
  11702.               ) ) ) ) ) )
  11703.               (LOAD
  11704.                 (when (and #| (consp rechts) |# (consp (car rechts)))
  11705.                   (let ((n (second item)))
  11706.                     (case (first (car rechts))
  11707.                       (CAR
  11708.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts)))
  11709.                           (case (first (cadr rechts))
  11710.                             (PUSH (ersetze 3 `(LOAD&CAR&PUSH ,n)))
  11711.                             (STORE
  11712.                               (ersetze 3
  11713.                                 `(LOAD&CAR&STORE ,n ,(second (cadr rechts)))
  11714.                       ) ) ) ) )
  11715.                       (CDR
  11716.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts)))
  11717.                           (case (first (cadr rechts))
  11718.                             (PUSH (ersetze 3 `(LOAD&CDR&PUSH ,n)))
  11719.                             (STORE
  11720.                               (when (eql n (second (cadr rechts)))
  11721.                                 (ersetze 3 `(LOAD&CDR&STORE ,n))
  11722.                       ) ) ) ) )
  11723.                       (CONS
  11724.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts))
  11725.                                    (eq (first (cadr rechts)) 'STORE)
  11726.                                    (eql (second (cadr rechts)) (- n 1))
  11727.                               )
  11728.                           (ersetze 3 `(LOAD&CONS&STORE ,(- n 1)))
  11729.                       ) )
  11730.                       (PUSH
  11731.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts))
  11732.                                    (or (equal (cadr rechts) CALLS-1+)
  11733.                                        (equal (cadr rechts) CALLS-1-)
  11734.                                    )
  11735.                                    #| (consp (cddr rechts)) |# (consp (caddr rechts))
  11736.                               )
  11737.                           (when (equal (caddr rechts) '(PUSH))
  11738.                             (ersetze 4
  11739.                               `(,(if (equal (cadr rechts) CALLS-1+)
  11740.                                    'LOAD&INC&PUSH
  11741.                                    'LOAD&DEC&PUSH
  11742.                                  )
  11743.                                 ,n
  11744.                                )
  11745.                           ) )
  11746.                           (when (and (eq (first (caddr rechts)) 'STORE)
  11747.                                      (eql (second (caddr rechts)) n)
  11748.                                 )
  11749.                             (ersetze 4
  11750.                               `(,(if (equal (cadr rechts) CALLS-1+)
  11751.                                    'LOAD&INC&STORE
  11752.                                    'LOAD&DEC&STORE
  11753.                                  )
  11754.                                 ,n
  11755.                                )
  11756.                         ) ) )
  11757.                         (ersetze 2 `(LOAD&PUSH ,n))
  11758.               ) ) ) ) )
  11759.               (JMPIFBOUNDP ; vereinfache (JMPIFBOUNDP n l) (NIL) (STORE n) l
  11760.                 (when (and #| (consp rechts) |#
  11761.                            (equal (car rechts) '(NIL))
  11762.                            #| (consp (cdr rechts)) |#
  11763.                            (consp (cadr rechts))
  11764.                            (eq (first (cadr rechts)) 'STORE)
  11765.                            (eql (second (cadr rechts)) (second item))
  11766.                            #| (consp (cddr rechts)) |#
  11767.                            (eq (caddr rechts) (third item))
  11768.                       )
  11769.                   (ersetze 3 `(UNBOUND->NIL ,(second item)))
  11770.               ) )
  11771.               (JSR
  11772.                 (if (and #| (consp rechts) |# (equal (car rechts) '(PUSH)))
  11773.                   (ersetze 2 `(JSR&PUSH ,(third item)))
  11774.                   (ersetze 1 `(JSR ,(third item)))
  11775.               ) )
  11776.               (UNBIND1
  11777.                 (let ((count 1))
  11778.                   (loop
  11779.                     (unless (and #| (consp rechts) |#
  11780.                                  (equal (car rechts) '(UNBIND1))
  11781.                             )
  11782.                       (return)
  11783.                     )
  11784.                     (incf count)
  11785.                     (setq rechts (cdr rechts))
  11786.                   )
  11787.                   (unless (eql count 1)
  11788.                     (setf (car mitte) `(UNBIND ,count))
  11789.                     (setf (cdr mitte) rechts)
  11790.                     (go weiter)
  11791.               ) ) )
  11792.               ;(RET (ersetze 1 '(SKIP&RET 0))) ; kommt nicht vor!
  11793.               (UNWIND-PROTECT-CLOSE (ersetze 1 '(UNWIND-PROTECT-CLOSE)))
  11794.               ((JMPIF JMPIFNOT) (ersetze 1 `(,(first item) ,(second item))))
  11795.               ((JMPHASH JMPHASHV)
  11796.                 (let ((hashtable (third item))
  11797.                       (labels (cddddr item)))
  11798.                   (maphash
  11799.                     #'(lambda (obj index) ; (gethash obj hashtable) = index
  11800.                         (setf (gethash obj hashtable) (nth index labels))
  11801.                       )
  11802.                     hashtable
  11803.                 ) )
  11804.                 (setf (cddddr item) '())
  11805.               )
  11806.               (HANDLER-OPEN
  11807.                 (do ((v (third item))
  11808.                      (labels (cddddr item) (cdr labels))
  11809.                      (i 1 (+ i 2)))
  11810.                     ((null labels))
  11811.                   (setf (svref v i) (car labels))
  11812.                 )
  11813.                 (setf (cdddr item) '())
  11814.               )
  11815.               (APPLY
  11816.                 (when (and #| (consp rechts) |#
  11817.                            (consp (car rechts))
  11818.                            (eq (first (car rechts)) 'SKIP)
  11819.                            #| (consp (cdr rechts)) |#
  11820.                            (equal (cadr rechts) '(RET))
  11821.                       )
  11822.                   (ersetze 3 `(APPLY&SKIP&RET ,(second item) ,(second (car rechts))))
  11823.               ) )
  11824.       ) ) ) )
  11825.       weiter ; Hier ist man mit (car mitte) fertig.
  11826.       (when (equal (car rechts) '(BARRIER))
  11827.         ; streiche Element (car rechts)
  11828.         (setf (cdr mitte) (setq rechts (cdr rechts)))
  11829.       )
  11830.     )
  11831.     code-list
  11832.   )
  11833. )
  11834.  
  11835.  
  11836. #|
  11837.                                 7. Schritt:
  11838.                 Umwandlung der Instruktionen in eine Byte-Folge
  11839.  
  11840. Erster Teilschritt: jeder Instruktion wird eine Klassifikation der Instruktion
  11841. und die LΣnge der Instruktion (Label-Operanden nicht mitgezΣhlt)
  11842. vorangestellt, jedem Label wird sein PC als Wert zugewiesen.
  11843. Dabei werden die OperandenlΣngen - soweit m÷glich - bestimmt, in Instruktionen
  11844. auftretende Labels werden durch (vermutliche VerweislΣnge . label) ersetzt.
  11845. So wird aus (BLOCK-OPEN 2 #:G7) --> (NL 2 . (67 2 (1 . #:G7))) .
  11846. Weitere Teilschritte:
  11847. Immer wieder wird die Codeliste durchlaufen, dabei werden Sprungverweise
  11848. eventuell von 1 auf 2 oder 6 Byte verlΣngert. Dadurch kann der Code insgesamt
  11849. nur lΣnger werden.
  11850. Letzter Teilschritt:
  11851. Die Sprungverweise werden in Distanzen umgesetzt, und die Codeliste wird
  11852. als Liste von Bytes neu aufgebaut.
  11853. |#
  11854. ; gibt an, wieviel Bytes ein numerischer Operand braucht:
  11855. (defun num-operand-length (n)
  11856.   (cond ((< n 128) 1) ; 7 Bit in 1 Byte
  11857.         ((< n 32768) 2) ; 15 Bit in 2 Bytes
  11858.         (t 6) ; sonst 6 Bytes
  11859. ) )
  11860. ; assembliert eine Code-Liste und liefert eine Bytecode-Liste:
  11861. (defun assemble-LAP (code-list)
  11862.   ; erster Teilschritt:
  11863.   (do ((code-listr code-list (cdr code-listr))
  11864.        (PC 0))
  11865.       ((null code-listr))
  11866.     (let ((item (car code-listr)))
  11867.       (if (atom item)
  11868.         (setf (symbol-value item) PC)
  11869.         (let ((instr-code (gethash (first item) instruction-codes)))
  11870.           (unless instr-code (compiler-error 'assemble-LAP "ILLEGAL INSTRUCTION"))
  11871.           (let ((instr-class (second (svref instruction-table instr-code)))
  11872.                 (instr-length 1))
  11873.             (if (and (eq instr-class 'K)
  11874.                      (< (second item)
  11875.                         (svref short-code-opsize (position (first item) instruction-table-K))
  11876.                 )    )
  11877.               (progn
  11878.                 (setq instr-code
  11879.                   (+ (svref short-code-ops
  11880.                             (position (first item) instruction-table-K)
  11881.                      )
  11882.                      (second item)
  11883.                 ) )
  11884.                 (setq instr-class 'O)
  11885.                 (setq item (list (first item)))
  11886.               )
  11887.               (case instr-class
  11888.                 (O)
  11889.                 ((K N NC) (incf instr-length (num-operand-length (second item))))
  11890.                 (B (incf instr-length 1))
  11891.                 (L (incf PC 1) (push 1 (second item)))
  11892.                 (NN (incf instr-length (num-operand-length (second item)))
  11893.                     (incf instr-length (num-operand-length (third item))) )
  11894.                 (NB (incf instr-length (num-operand-length (second item)))
  11895.                     (incf instr-length 1) )
  11896.                 (BN (incf instr-length 1)
  11897.                     (incf instr-length (num-operand-length (third item))) )
  11898.                 (NNN (incf instr-length (num-operand-length (second item)))
  11899.                      (incf instr-length (num-operand-length (third item)))
  11900.                      (incf instr-length (num-operand-length (fourth item))) )
  11901.                 (NBN (incf instr-length (num-operand-length (second item)))
  11902.                      (incf instr-length 1)
  11903.                      (incf instr-length (num-operand-length (fourth item))) )
  11904.                 (NNNN (incf instr-length (num-operand-length (second item)))
  11905.                       (incf instr-length (num-operand-length (third item)))
  11906.                       (incf instr-length (num-operand-length (fourth item)))
  11907.                       (incf instr-length (num-operand-length (fifth item))) )
  11908.                 (NL (incf instr-length (num-operand-length (second item)))
  11909.                     (incf PC 1) (push 1 (third item)) )
  11910.                 (BL (incf instr-length 1)
  11911.                     (incf PC 1) (push 1 (third item)) )
  11912.                 (NNL (incf instr-length (num-operand-length (second item)))
  11913.                      (incf instr-length (num-operand-length (third item)))
  11914.                      (incf PC 1) (push 1 (fourth item)) )
  11915.                 (NBL (incf instr-length (num-operand-length (second item)))
  11916.                      (incf instr-length 1)
  11917.                      (incf PC 1) (push 1 (fourth item)) )
  11918.                 (NHL (incf instr-length (num-operand-length (second item)))
  11919.                      (incf PC 1) (push 1 (fourth item)) )
  11920.                 (NLX (incf instr-length (num-operand-length (second item)))
  11921.                      (do ((L (cddr item) (cdr L)))
  11922.                          ((null L))
  11923.                        (incf PC 1) (push 1 (car L))
  11924.                 )    )
  11925.             ) )
  11926.             (incf PC instr-length)
  11927.             (setf (car code-listr)
  11928.               (list* instr-class instr-length instr-code (cdr item))
  11929.             )
  11930.   ) ) ) ) )
  11931.   ; weitere Teilschritte:
  11932.   (loop
  11933.     (unless
  11934.       (let ((modified nil) (PC 0))
  11935.         (dolist (item code-list)
  11936.           (if (atom item)
  11937.             (setf (symbol-value item) PC)
  11938.             (progn
  11939.               (incf PC (cadr item))
  11940.               (when (memq (car item) '(L NL BL NNL NBL NHL NLX))
  11941.                 (let ((itemargs (cdddr item)))
  11942.                   (dolist (x (case (car item)
  11943.                                (L itemargs)
  11944.                                ((NL BL NLX) (cdr itemargs))
  11945.                                ((NNL NBL NHL) (cddr itemargs))
  11946.                           )  )
  11947.                     (incf PC (car x))
  11948.                     (let ((new-dist (- (symbol-value (cdr x)) PC)))
  11949.                       ; bisher angenommene SprunglΣnge und neu errechnete abgleichen:
  11950.                       (if (<= -64 new-dist 63) ; 7 Bits in 1 Byte
  11951.                         () ; SprunglΣnge bleibt 1
  11952.                         (if (<= -16384 new-dist 16383) ; 15 Bits in 2 Bytes
  11953.                           (case (car x)
  11954.                             (1 (setf (car x) 2) ; neue SprunglΣnge=2
  11955.                                (incf PC 1) ; gibt 2-1=1 Bytes VerlΣngerung
  11956.                                (setq modified t)
  11957.                           ) )
  11958.                           ; 32 Bits in 6 Bytes
  11959.                           (case (car x)
  11960.                             (1 (setf (car x) 6) ; neue SprunglΣnge=6
  11961.                                (incf PC 5) ; gibt 6-1=5 Bytes VerlΣngerung
  11962.                                (setq modified t)
  11963.                             )
  11964.                             (2 (setf (car x) 6) ; neue SprunglΣnge=6
  11965.                                (incf PC 4) ; gibt 6-2=4 Bytes VerlΣngerung
  11966.                                (setq modified t)
  11967.                       ) ) ) )
  11968.               ) ) ) )
  11969.         ) ) )
  11970.         modified
  11971.       )
  11972.       (return) ; nichts mehr verΣndert -> alle SprunglΣngen optimal
  11973.   ) )
  11974.   ; letzter Teilschritt:
  11975.   (let ((byte-list '()) (PC 0))
  11976.     (flet ((new-byte (n) (push n byte-list)))
  11977.       (flet ((num-operand (n)
  11978.                (cond ((< n 128) (new-byte n))
  11979.                      ((< n 32768) (new-byte (+ 128 (ldb (byte 7 8) n)))
  11980.                                   (new-byte (ldb (byte 8 0) n))
  11981.                      )
  11982.                      (t (compiler-error 'assemble-LAP "15 BIT"))
  11983.              ) )
  11984.              (label-operand (x)
  11985.                (incf PC (car x))
  11986.                (let ((dist (- (symbol-value (cdr x)) PC)))
  11987.                  (case (car x)
  11988.                    (1 (new-byte (ldb (byte 7 0) dist)))
  11989.                    (2 (new-byte (+ 128 (ldb (byte 7 8) dist)))
  11990.                       (new-byte (ldb (byte 8 0) dist))
  11991.                    )
  11992.                    (6 (new-byte 128) (new-byte 0)
  11993.                       (new-byte (ldb (byte 8 24) dist))
  11994.                       (new-byte (ldb (byte 8 16) dist))
  11995.                       (new-byte (ldb (byte 8 8) dist))
  11996.                       (new-byte (ldb (byte 8 0) dist))
  11997.                  ) )
  11998.             )) )
  11999.         (dolist (item code-list)
  12000.           (when (consp item)
  12001.             (incf PC (cadr item))
  12002.             (new-byte (caddr item))
  12003.             (case (car item)
  12004.               (O) ; darin fallen auch die 1-Byte-Befehle vom Typ K
  12005.               ((K N) (num-operand (second (cddr item))))
  12006.               (B (new-byte (second (cddr item))))
  12007.               (L (label-operand (second (cddr item))))
  12008.               (NN (num-operand (second (cddr item)))
  12009.                   (num-operand (third (cddr item))) )
  12010.               (NB (num-operand (second (cddr item)))
  12011.                   (new-byte (third (cddr item))) )
  12012.               (BN (new-byte (second (cddr item)))
  12013.                   (num-operand (third (cddr item))) )
  12014.               (NNN (num-operand (second (cddr item)))
  12015.                    (num-operand (third (cddr item)))
  12016.                    (num-operand (fourth (cddr item))) )
  12017.               (NBN (num-operand (second (cddr item)))
  12018.                    (new-byte (third (cddr item)))
  12019.                    (num-operand (fourth (cddr item))) )
  12020.               (NNNN (num-operand (second (cddr item)))
  12021.                     (num-operand (third (cddr item)))
  12022.                     (num-operand (fourth (cddr item)))
  12023.                     (num-operand (fifth (cddr item))) )
  12024.               (NL (num-operand (second (cddr item)))
  12025.                   (label-operand (third (cddr item))) )
  12026.               (BL (new-byte (second (cddr item)))
  12027.                   (label-operand (third (cddr item))) )
  12028.               (NNL (num-operand (second (cddr item)))
  12029.                    (num-operand (third (cddr item)))
  12030.                    (label-operand (fourth (cddr item))) )
  12031.               (NBL (num-operand (second (cddr item)))
  12032.                    (new-byte (third (cddr item)))
  12033.                    (label-operand (fourth (cddr item))) )
  12034.               (NHL (num-operand (second (cddr item)))
  12035.                    (let ((ht (third (cddr item))))
  12036.                      (maphash
  12037.                        #'(lambda (obj x) ; x = (gethash obj ht)
  12038.                            (setf (gethash obj ht) (- (symbol-value x) PC))
  12039.                          )
  12040.                        ht
  12041.                    ) )
  12042.                    (label-operand (fourth (cddr item)))
  12043.               )
  12044.               (NC (num-operand (second (cddr item)))
  12045.                   (let* ((v (third (cddr item)))
  12046.                          (m (length v)))
  12047.                     (do ((i 1 (+ i 2)))
  12048.                         ((>= i m))
  12049.                       (setf (svref v i) (symbol-value (svref v i)))
  12050.               )   ) )
  12051.               (NLX (num-operand (second (cddr item)))
  12052.                    (dolist (x (cddr (cddr item))) (label-operand x)) )
  12053.             )
  12054.         ) )
  12055.     ) )
  12056.     (nreverse byte-list)
  12057. ) )
  12058.  
  12059. ; die Umkehrung zu assemble-LAP : liefert zu einer Bytecode-Liste die dazu
  12060. ; geh÷rige Codeliste. In dieser steht allerdings vor jedem Item noch der PC.
  12061. (defun disassemble-LAP (byte-list const-list)
  12062.   (let ((code-list '()) (PC 0) instr-PC (label-alist '()))
  12063.     ; label-alist ist eine Liste von Conses (PC . label), in der die PCs streng
  12064.     ; fallend geordnet sind.
  12065.     (flet ((PC->label-a (PC)
  12066.              (cons PC (make-symbol
  12067.                         (concatenate 'string "L" (prin1-to-string PC))
  12068.            ) )        )
  12069.            (next-byte () (incf PC) (pop byte-list))
  12070.           )
  12071.       (flet ((num-operand ()
  12072.                (let ((a (next-byte)))
  12073.                  (cond ((< a 128) a)
  12074.                        (t (+ (* 256 (- a 128)) (next-byte)))
  12075.              ) ) )
  12076.              (label-operand
  12077.                   (&optional
  12078.                     (dist
  12079.                       (let ((a (next-byte)))
  12080.                         (cond ((< a 128) (if (< a 64) a (- a 128)))
  12081.                               (t (setq a (- a 128))
  12082.                                  (unless (< a 64) (setq a (- a 128)))
  12083.                                  (setq a (+ (* 256 a) (next-byte)))
  12084.                                  (if (zerop a)
  12085.                                    (+ (* 256 (+ (* 256 (+ (* 256 (next-byte))
  12086.                                                           (next-byte)
  12087.                                                 )      )
  12088.                                                 (next-byte)
  12089.                                       )      )
  12090.                                       (next-byte)
  12091.                                    )
  12092.                                    a
  12093.                     ) ) )     )  )
  12094.                     (label-PC (+ PC dist))
  12095.                   )
  12096.                ; Suche label-PC in label-alist:
  12097.                (do* ((L1 nil L2)
  12098.                      (L2 label-alist (cdr L2))) ; L1 = nil oder L2 = (cdr L1)
  12099.                     ((cond
  12100.                        ((or (null L2) (> label-PC (caar L2))) ; einfⁿgen
  12101.                         (setq L2 (cons (PC->label-a label-PC) L2))
  12102.                         (if L1 (setf (cdr L1) L2) (setq label-alist L2))
  12103.                         t)
  12104.                        ((= label-PC (caar L2)) t)
  12105.                        (t nil)
  12106.                      )
  12107.                      (cdar L2)
  12108.             )) )    )
  12109.         (loop
  12110.           (when (null byte-list) (return))
  12111.           (setq instr-PC PC) ; PC beim Start der Instruktion
  12112.           (let ((instruction
  12113.                   (let ((instr-code (next-byte)))
  12114.                     (if (>= instr-code short-code-base)
  12115.                       (let* ((q (position instr-code short-code-ops :test #'>= :from-end t))
  12116.                              (r (- instr-code (svref short-code-ops q))))
  12117.                         (list (svref instruction-table-K q) r)
  12118.                       )
  12119.                       (let* ((table-entry (svref instruction-table instr-code))
  12120.                              (instr-name (first table-entry)))
  12121.                         (case (second table-entry)
  12122.                           (O (list instr-name))
  12123.                           ((K N) (list instr-name (num-operand)))
  12124.                           (B (list instr-name (next-byte)))
  12125.                           (L (list instr-name (label-operand)))
  12126.                           (NN (list instr-name (num-operand) (num-operand)))
  12127.                           (NB (list instr-name (num-operand) (next-byte)))
  12128.                           (BN (list instr-name (next-byte) (num-operand)))
  12129.                           (NNN (list instr-name (num-operand) (num-operand) (num-operand)))
  12130.                           (NBN (list instr-name (num-operand) (next-byte) (num-operand)))
  12131.                           (NNNN (list instr-name (num-operand) (num-operand) (num-operand) (num-operand)))
  12132.                           (NL (list instr-name (num-operand) (label-operand)))
  12133.                           (BL (list instr-name (next-byte) (label-operand)))
  12134.                           (NNL (list instr-name (num-operand) (num-operand) (label-operand)))
  12135.                           (NBL (list instr-name (num-operand) (next-byte) (label-operand)))
  12136.                           (NHL (let* ((n (num-operand))
  12137.                                       (ht (if (eq instr-name 'JMPHASH)
  12138.                                             (nth n const-list)           ; JMPHASH
  12139.                                             (svref (first const-list) n) ; JMPHASHV
  12140.                                       )   )
  12141.                                       (labels '()))
  12142.                                  (maphash
  12143.                                    #'(lambda (obj dist)
  12144.                                        (declare (ignore obj))
  12145.                                        (push (label-operand dist) labels)
  12146.                                      )
  12147.                                    ht
  12148.                                  )
  12149.                                  (list* instr-name n (label-operand) labels)
  12150.                           )    )
  12151.                           (NC (let* ((n (num-operand))
  12152.                                      (v (car (nth n const-list)))
  12153.                                      (m (length v))
  12154.                                      (labels '()))
  12155.                                 (do ((i 1 (+ i 2)))
  12156.                                     ((>= i m))
  12157.                                   (push (label-operand nil (svref v i)) labels)
  12158.                                 )
  12159.                                 (list* instr-name n (nreverse labels))
  12160.                           )   )
  12161.                           (NLX (let* ((n (num-operand))
  12162.                                       (m (length (nth n const-list)))
  12163.                                       (L '()))
  12164.                                  (dotimes (i m) (push (label-operand) L))
  12165.                                  (list* instr-name n (nreverse L))
  12166.                           )    )
  12167.                )) ) ) ) )
  12168.             (push (cons instr-PC instruction) code-list)
  12169.         ) )
  12170.     ) )
  12171.     ; (setq label-alist (sort label-alist #'> :key #'car))
  12172.     ; code-list umdrehen und dabei die Labels einfⁿgen:
  12173.     (let ((new-code-list '()))
  12174.       (loop
  12175.         (when (and new-code-list label-alist
  12176.                    (= (caar new-code-list) (caar label-alist))
  12177.               )
  12178.           (push (car label-alist) new-code-list)
  12179.           (setq label-alist (cdr label-alist))
  12180.         )
  12181.         (when (null code-list) (return))
  12182.         ; eine Instruktion von code-list in new-code-list ⁿbernehmen:
  12183.         (psetq code-list (cdr code-list)
  12184.                new-code-list (rplacd code-list new-code-list)
  12185.       ) )
  12186.       new-code-list
  12187. ) ) )
  12188.  
  12189.  
  12190. #|
  12191.                            8. Schritt:
  12192.                     funktionales Objekt bilden
  12193.  
  12194. Die Funktion make-closure wird dazu vorausgesetzt.
  12195. |#
  12196. ; trΣgt eine Byteliste als Code in fnode ein.
  12197. (defun create-fun-obj (fnode byte-list SPdepth)
  12198.   (setf (fnode-code fnode)
  12199.     (make-closure
  12200.       :name (fnode-name fnode)
  12201.       :codevec
  12202.         (macrolet ((as-word (anz)
  12203.                      (if *big-endian*
  12204.                        ; BIG-ENDIAN-Prozessor
  12205.                        `(floor ,anz 256)
  12206.                        ; LITTLE-ENDIAN-Prozessor
  12207.                        `(multiple-value-bind (q r) (floor ,anz 256) (values r q))
  12208.                   )) )
  12209.           (multiple-value-call #'list*
  12210.             (as-word (car SPdepth))
  12211.             (as-word (cdr SPdepth))
  12212.             (as-word (fnode-req-anz fnode))
  12213.             (as-word (fnode-opt-anz fnode))
  12214.             (+ (if (fnode-rest-flag fnode) 1 0)
  12215.                (if (fnode-gf-p fnode) 16 0)
  12216.                (if (fnode-keyword-flag fnode)
  12217.                  (+ 128 (if (fnode-allow-other-keys-flag fnode) 64 0))
  12218.                  0
  12219.             )  )
  12220.             (values ; Argumenttyp-Kⁿrzel
  12221.               (let ((req-anz (fnode-req-anz fnode))
  12222.                     (opt-anz (fnode-opt-anz fnode))
  12223.                     (rest (fnode-rest-flag fnode))
  12224.                     (key (fnode-keyword-flag fnode)))
  12225.                 (cond ((and (not rest) (not key) (< (+ req-anz opt-anz) 6))
  12226.                        (+ (svref '#(1 7 12 16 19 21) opt-anz) req-anz)
  12227.                       )
  12228.                       ((and rest (not key) (zerop opt-anz) (< req-anz 5))
  12229.                        (+ 22 req-anz)
  12230.                       )
  12231.                       ((and (not rest) key (< (+ req-anz opt-anz) 5))
  12232.                        (+ (svref '#(27 32 36 39 41) opt-anz) req-anz)
  12233.                       )
  12234.                       (t 0)
  12235.             ) ) )
  12236.             (if (fnode-keyword-flag fnode)
  12237.               (multiple-value-call #'values
  12238.                 (as-word (length (fnode-keywords fnode)))
  12239.                 (as-word (fnode-Keyword-Offset fnode))
  12240.               )
  12241.               (values)
  12242.             )
  12243.             byte-list
  12244.         ) )
  12245.       :consts
  12246.         (let* ((spare-list (make-list (fnode-Keyword-Offset fnode)))
  12247.                (l (append
  12248.                     spare-list
  12249.                     (fnode-keywords fnode)
  12250.                     (if *compiling-from-file*
  12251.                       (mapcar #'(lambda (value form)
  12252.                                   (if form (make-load-time-eval form) value)
  12253.                                 )
  12254.                               (fnode-Consts fnode) (fnode-Consts-forms fnode)
  12255.                       )
  12256.                       (fnode-Consts fnode)
  12257.               ))  ) )
  12258.           (if (fnode-gf-p fnode)
  12259.             (append spare-list (list (coerce l 'simple-vector)))
  12260.             l
  12261.         ) )
  12262.   ) )
  12263.   fnode
  12264. )
  12265.  
  12266. ; Liefert die Signatur eines funktionalen Objekts,
  12267. ; als Werte:
  12268. ; 1. req-anz
  12269. ; 2. opt-anz
  12270. ; 3. rest-p
  12271. ; 4. key-p
  12272. ; 5. keyword-list
  12273. ; 6. allow-other-keys-p
  12274. ; und zusΣtzlich
  12275. ; 7. byte-list
  12276. ; 8. const-list
  12277. (defun signature (closure)
  12278.   (let ((const-list (closure-consts closure))
  12279.         (byte-list (closure-codevec closure)))
  12280.     (macrolet ((pop2 (listvar)
  12281.                  (if *big-endian*
  12282.                    ; BIG-ENDIAN-Prozessor
  12283.                    `(+ (* 256 (pop ,listvar)) (pop ,listvar))
  12284.                    ; LITTLE-ENDIAN-Prozessor
  12285.                    `(+ (pop ,listvar) (* 256 (pop ,listvar)))
  12286.               )) )
  12287.       (pop byte-list) (pop byte-list)
  12288.       (pop byte-list) (pop byte-list)
  12289.       (let* ((req-anz (pop2 byte-list))
  12290.              (opt-anz (pop2 byte-list))
  12291.              (h (pop byte-list))
  12292.              (key-p (logbitp 7 h)))
  12293.         (pop byte-list)
  12294.         (values
  12295.           req-anz
  12296.           opt-anz
  12297.           (logbitp 0 h)
  12298.           key-p
  12299.           (when key-p
  12300.             (let ((kw-count (pop2 byte-list))
  12301.                   (kw-offset (pop2 byte-list)))
  12302.               (subseq (if (logbitp 4 h) ; generische Funktion?
  12303.                         (coerce (first const-list) 'list)
  12304.                         const-list
  12305.                       )
  12306.                       kw-offset (+ kw-offset kw-count)
  12307.           ) ) )
  12308.           (logbitp 6 h)
  12309.           byte-list
  12310.           const-list
  12311. ) ) ) ) )
  12312.  
  12313.  
  12314. ;                  D R I T T E R   P A S S
  12315.  
  12316. (defun pass3 ()
  12317.   (dolist (pair *fnode-fixup-table*)
  12318.     (let ((code (fnode-code (first pair))) (n (second pair)))
  12319.       (macrolet ((closure-const (code n)
  12320.                    #-CLISP `(nth ,n (closure-consts ,code))
  12321.                    #+CLISP `(sys::%record-ref ,code (+ 2 ,n))
  12322.                 ))
  12323.         (setf (closure-const code n) (fnode-code (closure-const code n)))
  12324. ) ) ) )
  12325.  
  12326.  
  12327. ;             T O P - L E V E L - A U F R U F
  12328.  
  12329. ; compiliert einen Lambdabody und liefert seinen Code.
  12330. (defun compile-lambdabody (name lambdabody)
  12331.   (let ((fnode (c-lambdabody name lambdabody)))
  12332.     (unless *no-code*
  12333.       (let ((*fnode-fixup-table* '()))
  12334.         (pass2 fnode)
  12335.         (pass3)
  12336.       )
  12337.       (fnode-code fnode)
  12338. ) ) )
  12339.  
  12340. ; wird bei (lambda (...) (declare (compile)) ...) aufgerufen und liefert ein
  12341. ; zu diesem Lambda-Ausdruck Σquivalentes funktionales Objekt.
  12342. (defun compile-lambda (name lambdabody %venv% %fenv% %benv% %genv% %denv%)
  12343.   (let ((*compiling* t)
  12344.         (*compiling-from-file* nil)
  12345.         (*c-listing-output* nil)
  12346.         (*c-error-output* *error-output*)
  12347.         (*known-special-vars* '())
  12348.         (*constant-special-vars* '())
  12349.         (*func* nil)
  12350.         (*fenv* %fenv%)
  12351.         (*benv* %benv%)
  12352.         (*genv* %genv%)
  12353.         (*venv* %venv%)
  12354.         (*venvc* nil)
  12355.         (*denv* %denv%)
  12356.         (*error-count* 0) (*warning-count* 0)
  12357.         (*no-code* nil)
  12358.        )
  12359.     (let ((funobj (compile-lambdabody name lambdabody)))
  12360.       (unless (zerop *error-count*)
  12361.         (return-from compile-lambda (compile-lambdabody name '(() NIL)))
  12362.       )
  12363.       funobj
  12364. ) ) )
  12365.  
  12366. ; wird bei (let/let*/multiple-value-bind ... (declare (compile)) ...) aufgerufen
  12367. ; und liefert ein funktionales Objekt, das - mit 0 Argumenten aufgerufen - diese
  12368. ; Form ausfⁿhrt.
  12369. (let ((form-count 0))
  12370.   (defun compile-form (form %venv% %fenv% %benv% %genv% %denv%)
  12371.     (compile-lambda (symbol-suffix '#:COMPILED-FORM (incf form-count))
  12372.                     `(() ,form)
  12373.                     %venv% %fenv% %benv% %genv% %denv%
  12374.   ) )
  12375. )
  12376.  
  12377. ; Common-Lisp-Funktion COMPILE
  12378. #-CROSS
  12379. (defun compile (name &optional (definition nil svar)
  12380.                      &aux (macro-flag nil) (trace-flag nil) (save-flag nil))
  12381.   (unless (function-name-p name)
  12382.     (error-of-type 'error
  12383.       (DEUTSCH "Name einer zu compilierenden Funktion mu▀ ein Symbol sein, nicht: ~S"
  12384.        ENGLISH "Name of function to be compiled must be a symbol, not ~S"
  12385.        FRANCAIS "Le nom d'une fonction α compiler doit Ωtre un symbole et non ~S")
  12386.       name
  12387.   ) )
  12388.   (let ((symbol (get-funname-symbol name)))
  12389.     (if svar
  12390.       ; Neudefinition von name als Funktion.
  12391.       (progn
  12392.         ; Ist name getraced -> falls vorher Macro, erst untracen.
  12393.         (when (and name (setq svar (get symbol 'sys::traced-definition)))
  12394.           (if (consp svar)
  12395.             (progn
  12396.               (warn (DEUTSCH "~S: ~S war getraced und wird umdefiniert!"
  12397.                      ENGLISH "~S: redefining ~S; it was traced!"
  12398.                      FRANCAIS "~S: ~S est redΘfinie, alors qu'elle Θtait tracΘe!")
  12399.                     'compile name
  12400.               )
  12401.               (sys::untrace2 name)
  12402.             )
  12403.             (setq trace-flag t)
  12404.         ) )
  12405.         (when (compiled-function-p definition)
  12406.           (warn (DEUTSCH "~S ist schon compiliert."
  12407.                  ENGLISH "~S is already compiled."
  12408.                  FRANCAIS "~S est dΘjα compilΘe.")
  12409.                 definition
  12410.           )
  12411.           (when name
  12412.             (if trace-flag
  12413.               (setf (get symbol 'sys::traced-definition) definition)
  12414.               (setf (symbol-function symbol) definition)
  12415.           ) )
  12416.           (return-from compile name)
  12417.         )
  12418.         (when name
  12419.           (setq save-flag
  12420.                 (cons `(SETF (FDEFINITION ',name) ',definition)
  12421.                       sys::*toplevel-environment*
  12422.         ) )     )
  12423.       )
  12424.       ; Compilierung der vorhandenen Funktions-/Macro-Definition.
  12425.       (progn
  12426.         (unless (fboundp symbol)
  12427.           (error-of-type 'undefined-function
  12428.             :name name
  12429.             (DEUTSCH "Funktion ~S ist undefiniert."
  12430.              ENGLISH "Undefined function ~S"
  12431.              FRANCAIS "Fonction non dΘfinie ~S.")
  12432.             name
  12433.         ) )
  12434.         (if (setq definition (get symbol 'sys::traced-definition))
  12435.           (setq trace-flag t)
  12436.           (setq definition (symbol-function symbol))
  12437.         )
  12438.         (when (and (consp definition) (eq (car definition) 'system::macro))
  12439.           (setq macro-flag t)
  12440.           (setq definition (cdr definition))
  12441.         )
  12442.         (when (compiled-function-p definition)
  12443.           (warn (DEUTSCH "~S ist schon compiliert."
  12444.                  ENGLISH "~S is already compiled."
  12445.                  FRANCAIS "~S est dΘjα compilΘe.")
  12446.                 name
  12447.           )
  12448.           (return-from compile name)
  12449.     ) ) )
  12450.     (unless (or (and (consp definition) (eq (car definition) 'lambda))
  12451.                 (sys::closurep definition)
  12452.             )
  12453.       (error-of-type 'error
  12454.         (DEUTSCH "Das ist weder ein Lambda-Ausdruck noch ein funktionales Objekt:~%~S"
  12455.          ENGLISH "Not a lambda expression nor a function: ~S"
  12456.          FRANCAIS "Ni expression lambda ni fonction : ~S")
  12457.         definition
  12458.     ) )
  12459.     (let ((*compiling* t)
  12460.           (*error-count* 0)
  12461.           (*warning-count* 0)
  12462.           (*compiling-from-file* nil)
  12463.           (*c-listing-output* nil)
  12464.           (*c-error-output* *error-output*)
  12465.           (*known-special-vars* '())
  12466.           (*constant-special-vars* '())
  12467.           (*func* nil)
  12468.           (*fenv* (if (sys::closurep definition)
  12469.                     (sys::%record-ref definition 5)
  12470.                     nil
  12471.           )       )
  12472.           (*benv* (if (sys::closurep definition)
  12473.                     (sys::%record-ref definition 6)
  12474.                     nil
  12475.           )       )
  12476.           (*genv* (if (sys::closurep definition)
  12477.                     (sys::%record-ref definition 7)
  12478.                     nil
  12479.           )       )
  12480.           (*venv* (if (sys::closurep definition)
  12481.                     (sys::%record-ref definition 4)
  12482.                     nil
  12483.           )       )
  12484.           (*venvc* nil)
  12485.           (*denv* (if (sys::closurep definition)
  12486.                     (sys::%record-ref definition 8)
  12487.                     *toplevel-denv*
  12488.           )       )
  12489.           (*no-code* nil))
  12490.       (let ((lambdabody (if (sys::closurep definition)
  12491.                           (sys::%record-ref definition 1)
  12492.                           (cdr definition)
  12493.            ))           )
  12494.         (let ((funobj (compile-lambdabody name lambdabody)))
  12495.           (unless (zerop *error-count*) (return-from compile nil))
  12496.           (if name
  12497.             (progn
  12498.               (when macro-flag (setq funobj (cons 'system::macro funobj)))
  12499.               (if trace-flag
  12500.                 (setf (get symbol 'sys::traced-definition) funobj)
  12501.                 (setf (symbol-function symbol) funobj)
  12502.               )
  12503.               (when save-flag
  12504.                 (setf (get symbol 'sys::definition) save-flag)
  12505.               )
  12506.               name
  12507.             )
  12508.             funobj
  12509. ) ) ) ) ) )
  12510.  
  12511. ; Top-Level-Formen mⁿssen einzeln aufs .fas-File rausgeschrieben werden,
  12512. ; wegen der Semantik von EVAL-WHEN und LOAD-TIME-VALUE.
  12513. ; Da Top-Level-Formen bei EVAL-WHEN, PROGN und LOCALLY auseinandergebrochen
  12514. ; werden k÷nnen, mu▀ man LET () verwenden, wenn man dies umgehen will.
  12515.  
  12516. ; Compiliert eine Top-Level-Form fⁿr COMPILE-FILE. Der *toplevel-name* wird
  12517. ; meist unverΣndert durchgereicht. *toplevel-for-value* gibt an, ob der Wert
  12518. ; gebraucht wird (fⁿr LOAD :PRINT T) oder nicht.
  12519. (defvar *toplevel-for-value*)
  12520. (defun compile-toplevel-form (form &optional (*toplevel-name* *toplevel-name*))
  12521.   (declare (special *toplevel-name*))
  12522.   (catch 'c-error
  12523.     ; CLtL2 S. 90: "Processing of top-level forms in the file compiler ..."
  12524.     ; 1. Schritt: Macroexpandieren
  12525.     (if (atom form)
  12526.       (when (symbolp form)
  12527.         (multiple-value-bind (macrop expansion) (venv-search-macro form *venv*)
  12528.           (when macrop ; Symbol-Macro ?
  12529.             (return-from compile-toplevel-form
  12530.               (compile-toplevel-form expansion) ; -> expandieren
  12531.       ) ) ) )
  12532.       (let ((fun (first form)))
  12533.         (when (symbolp fun)
  12534.           (multiple-value-bind (a b c) (fenv-search fun)
  12535.             (declare (ignore b c))
  12536.             (if (null a)
  12537.               ; nicht lokal definiert
  12538.               (case fun
  12539.                 (PROGN ; vgl. c-PROGN
  12540.                   (test-list form 1)
  12541.                   (let ((L (cdr form))) ; Liste der Formen
  12542.                     (cond ((null L) (compile-toplevel-form 'NIL)) ; keine Form
  12543.                           ((null (cdr L)) (compile-toplevel-form (car L))) ; genau eine Form
  12544.                           (t (let ((subform-count 0))
  12545.                                (do ((Lr L))
  12546.                                    ((null Lr))
  12547.                                  (let* ((subform (pop Lr))
  12548.                                         (*toplevel-for-value* (and *toplevel-for-value* (null Lr))))
  12549.                                    (compile-toplevel-form subform
  12550.                                      (symbol-suffix *toplevel-name* (incf subform-count))
  12551.                   ) )     )  ) ) ) )
  12552.                   (return-from compile-toplevel-form)
  12553.                 )
  12554.                 ((LOCALLY EVAL-WHEN COMPILER-LET MACROLET SYMBOL-MACROLET)
  12555.                   (let ((*form* form))
  12556.                     ; c-LOCALLY bzw. c-EVAL-WHEN bzw. c-COMPILER-LET bzw.
  12557.                     ; c-MACROLET bzw. c-SYMBOL-MACROLET aufrufen:
  12558.                     (funcall (gethash fun c-form-table) #'compile-toplevel-form)
  12559.                   )
  12560.                   (return-from compile-toplevel-form)
  12561.                 )
  12562.                 (t (when (macro-function fun) ; globaler Macro ?
  12563.                      (return-from compile-toplevel-form
  12564.                        (compile-toplevel-form (macroexpand-1 form (vector *venv* *fenv*))) ; -> expandieren
  12565.               ) )  ) )
  12566.               ; lokal definiert
  12567.               (when (eq a 'SYSTEM::MACRO) ; lokaler Macro
  12568.                 (return-from compile-toplevel-form
  12569.                   (compile-toplevel-form (macroexpand-1 form (vector *venv* *fenv*))) ; -> expandieren
  12570.               ) )
  12571.     ) ) ) ) )
  12572.     ; 2. Schritt: compilieren und rausschreiben
  12573.     (when (and (not *toplevel-for-value*) (c-constantp form))
  12574.       (return-from compile-toplevel-form)
  12575.     )
  12576.     (let ((*package-tasks* '()))
  12577.       (setq form
  12578.         (compile-lambdabody *toplevel-name*
  12579.           `(() ,form ,@(if *toplevel-for-value* '() '((VALUES)) ) )
  12580.       ) )
  12581.       (when *c-listing-output*
  12582.         (disassemble-closures form *c-listing-output*)
  12583.       )
  12584.       (when *fasoutput-stream*
  12585.         (terpri *fasoutput-stream*)
  12586.         (write form :stream *fasoutput-stream* :pretty t
  12587.                     :readably t
  12588.                     ; :closure t :circle t :array t :gensym t
  12589.                     ; :escape t :level nil :length nil :radix t
  12590.       ) )
  12591.       (when *package-tasks*
  12592.         (c-eval-when-compile `(PROGN ,@(nreverse *package-tasks*)))
  12593.       )
  12594. ) ) )
  12595.  
  12596. ; C-Output-File ÷ffnen, falls noch nicht offen:
  12597. (defun prepare-coutput-file ()
  12598.   (if (and *compiling-from-file* *coutput-file*)
  12599.     (progn
  12600.       (unless *coutput-stream*
  12601.         (setq *coutput-stream* (open *coutput-file* :direction :output))
  12602.         (format *coutput-stream* "#include \"clisp.h\"~%~%")
  12603.       )
  12604.       t
  12605.     )
  12606.     nil
  12607. ) )
  12608. ; Hook fⁿrs FFI:
  12609. (defun finalize-coutput-file ())
  12610.  
  12611. ; Common-Lisp-Funktion COMPILE-FILE
  12612. ; file          sollte ein Pathname/String/Symbol sein.
  12613. ; :output-file  sollte nil oder t oder ein Pathname/String/Symbol oder
  12614. ;               ein Output-Stream sein. Default: t.
  12615. ; :listing      sollte nil oder t oder ein Pathname/String/Symbol oder
  12616. ;               ein Output-Stream sein. Default: nil.
  12617. ; :warnings     gibt an, ob die Warnings auch auf dem Bildschirm erscheinen
  12618. ;               sollen.
  12619. ; :verbose      gibt an, ob die Errors auch auf dem Bildschirm erscheinen
  12620. ;               sollen.
  12621. (defun compile-file (file &key (output-file 'T) listing
  12622.                                ((:warnings *compile-warnings*) *compile-warnings*)
  12623.                                ((:verbose *compile-verbose*) *compile-verbose*)
  12624.                                ((:print *compile-print*) *compile-print*)
  12625.                           &aux (top-call nil) liboutput-file (*coutput-file* nil)
  12626.                                (new-output-stream nil) (new-listing-stream nil)
  12627.                     )
  12628.   (setq file (or (first (search-file file *source-file-types*))
  12629.                  (merge-pathnames file (merge-pathnames '#".lsp"))
  12630.   )          )
  12631.   (when (and output-file (not (streamp output-file)))
  12632.     (setq output-file (if (eq output-file 'T)
  12633.                         (merge-pathnames '#".fas" file)
  12634.                         (merge-pathnames output-file)
  12635.     )                 )
  12636.     (setq liboutput-file (merge-pathnames '#".lib" output-file))
  12637.     (setq *coutput-file* (merge-pathnames '#".c" output-file))
  12638.     (setq new-output-stream t)
  12639.   )
  12640.   (when (and listing (not (streamp listing)))
  12641.     (setq listing (if (eq listing 'T)
  12642.                     (merge-pathnames '#".lis" file)
  12643.                     (merge-pathnames listing)
  12644.     )             )
  12645.     (setq new-listing-stream t)
  12646.   )
  12647.   (with-open-file (istream file :direction :input-immutable)
  12648.     (let ((listing-stream (if new-listing-stream
  12649.                             (open listing :direction :output)
  12650.                             (if (streamp listing) listing nil)
  12651.          ))               ) ; ein Stream oder NIL
  12652.       (unwind-protect
  12653.         (let ((*compile-file-pathname* file)
  12654.               (*compile-file-truename* (truename file))
  12655.               (*compile-file-lineno1* nil)
  12656.               (*compile-file-lineno2* nil)
  12657.               (*fasoutput-stream* (if new-output-stream
  12658.                                     (open output-file :direction :output)
  12659.                                     (if (streamp output-file) output-file nil)
  12660.               )                   ) ; ein Stream oder NIL
  12661.               (*liboutput-stream* (if new-output-stream
  12662.                                     (open liboutput-file :direction :output)
  12663.                                     nil
  12664.               )                   ) ; ein Stream oder NIL
  12665.               (*coutput-stream* nil) ; ein Stream oder vorerst NIL
  12666.               (*ffi-module* nil) ; vorerst NIL
  12667.               (compilation-successful nil))
  12668.           (unwind-protect
  12669.             (progn
  12670.               (when listing-stream
  12671.                 (format listing-stream
  12672.                   (DEUTSCH "~&Listing der Compilation von Datei ~A~%am ~@? durch ~A in der Version ~A"
  12673.                    ENGLISH "~&Listing of compilation of file ~A~%on ~@? by ~A, version ~A"
  12674.                    FRANCAIS "~&Listage de la compilation du fichier ~A~%le ~@? par ~A, version ~A")
  12675.                   file
  12676.                   (date-format)
  12677.                   (multiple-value-list (get-decoded-time))
  12678.                     ; Liste (sec min hour day month year ...)
  12679.                   (lisp-implementation-type) (lisp-implementation-version)
  12680.               ) )
  12681.               (unless *compiling* ; Variablen setzen, nicht binden!
  12682.                 (setq *functions-with-errors* '())
  12683.                 (setq *known-special-vars* '()) (setq *unknown-free-vars* '())
  12684.                 (setq *constant-special-vars* '())
  12685.                 (setq *known-functions* '()) (setq *unknown-functions* '())
  12686.                 (setq *inline-functions* '()) (setq *notinline-functions* '())
  12687.                 (setq *inline-definitions* '())
  12688.                 (setq *user-declaration-types* '())
  12689.                 (setq *compiled-modules* '())
  12690.                 (setq top-call t)
  12691.               )
  12692.               (let ((*compiling* t)
  12693.                     (*compiling-from-file* t)
  12694.                     (*package* *package*)
  12695.                     (*readtable* *readtable*)
  12696.                     (*c-listing-output* listing-stream)
  12697.                     (*c-error-output*
  12698.                       (if listing-stream
  12699.                         (make-broadcast-stream *error-output* listing-stream)
  12700.                         *error-output*
  12701.                     ) )
  12702.                     (*func* nil)
  12703.                     (*fenv* nil)
  12704.                     (*benv* nil)
  12705.                     (*genv* nil)
  12706.                     (*venv* nil)
  12707.                     (*venvc* nil)
  12708.                     (*denv* *toplevel-denv*)
  12709.                     (*error-count* 0) (*warning-count* 0)
  12710.                     (*no-code* (and (null *fasoutput-stream*) (null listing-stream)))
  12711.                     (*toplevel-for-value* t)
  12712.                     (eof-value "EOF")
  12713.                     (form-count 0)
  12714.                    )
  12715.                 (c-comment (DEUTSCH "~%Datei ~A wird compiliert..."
  12716.                             ENGLISH "~%Compiling file ~A ..."
  12717.                             FRANCAIS "~%Compilation du fichier ~A...")
  12718.                            file
  12719.                 )
  12720.                 (when *fasoutput-stream*
  12721.                   (let ((*package* *keyword-package*))
  12722.                     (write `(SYSTEM::VERSION ',(version)) :stream *fasoutput-stream*
  12723.                            :readably t
  12724.                            ; :escape t :level nil :length nil :radix t
  12725.                 ) ) )
  12726.                 (loop
  12727.                   (peek-char t istream nil eof-value)
  12728.                   (setq *compile-file-lineno1* (line-number istream))
  12729.                   (let ((form (read istream nil eof-value)))
  12730.                     (setq *compile-file-lineno2* (line-number istream))
  12731.                     (when (eql form eof-value) (return))
  12732.                     (when *compile-print*
  12733.                       (format t "~%; ~A" (sys::write-to-short-string form (- sys::*prin-linelength* 2)))
  12734.                     )
  12735.                     (compile-toplevel-form form
  12736.                       (symbol-suffix '#:TOP-LEVEL-FORM (incf form-count))
  12737.                 ) ) )
  12738.                 (finalize-coutput-file)
  12739.                 (c-comment (DEUTSCH "~&~%Compilation von Datei ~A beendet."
  12740.                             ENGLISH "~&~%Compilation of file ~A is finished."
  12741.                             FRANCAIS "~&~%Compilation du fichier ~A terminΘe.")
  12742.                            file
  12743.                 )
  12744.                 (c-comment (DEUTSCH "~%~D Error~:P, ~D Warnung~:[en~;~]"
  12745.                             ENGLISH "~%~D error~:P, ~D warning~:P"
  12746.                             FRANCAIS "~%~D erreur~:P, ~D avertissement~:P")
  12747.                            *error-count* *warning-count* (DEUTSCH (eql *warning-count* 1))
  12748.                 )
  12749.                 (when top-call
  12750.                   (when *functions-with-errors*
  12751.                     (c-comment (DEUTSCH "~%Es gab Errors in den folgenden Funktionen:~%~{~<~%~:; ~S~>~^~}"
  12752.                                 ENGLISH "~%There were errors in the following functions:~%~{~<~%~:; ~S~>~^~}"
  12753.                                 FRANCAIS "~%Il y a des erreurs dans les fonctions :~%~{~<~%~:; ~S~>~^~}" )
  12754.                                (nreverse *functions-with-errors*)
  12755.                   ) )
  12756.                   (setq *unknown-functions*
  12757.                     (nset-difference *unknown-functions* *known-functions* :test #'equal)
  12758.                   )
  12759.                   (when *unknown-functions*
  12760.                     (c-comment (DEUTSCH "~%Folgende Funktionen wurden verwendet, aber nicht definiert:~%~{~<~%~:; ~S~>~^~}"
  12761.                                 ENGLISH "~%The following functions were used but not defined:~%~{~<~%~:; ~S~>~^~}"
  12762.                                 FRANCAIS "~%Les fonctions suivantes sont utilisΘes mais non dΘfinies :~%~{~<~%~:; ~S~>~^~}")
  12763.                                (nreverse *unknown-functions*)
  12764.                   ) )
  12765.                   (let ((unknown-vars (set-difference *unknown-free-vars* *known-special-vars*))
  12766.                         (too-late-vars (intersection *unknown-free-vars* *known-special-vars*)))
  12767.                     (when unknown-vars
  12768.                       (c-comment (DEUTSCH "~%Folgende Special-Variablen wurden nicht definiert:~%~{~<~%~:; ~S~>~^~}"
  12769.                                   ENGLISH "~%The following special variables were not defined:~%~{~<~%~:; ~S~>~^~}"
  12770.                                   FRANCAIS "~%Les variables utilisΘes comme SPECIAL ne sont pas dΘfinies :~%~{~<~%~:; ~S~>~^~}")
  12771.                                  (nreverse unknown-vars)
  12772.                     ) )
  12773.                     (when too-late-vars
  12774.                       (c-comment (DEUTSCH "~%Folgende Special-Variablen wurden zu spΣt definiert:~%~{~<~%~:; ~S~>~^~}"
  12775.                                   ENGLISH "~%The following special variables were defined too late:~%~{~<~%~:; ~S~>~^~}"
  12776.                                   FRANCAIS "~%Les variables dΘclarΘes SPECIAL sont dΘfinies trop tard :~%~{~<~%~:; ~S~>~^~}")
  12777.                                  (nreverse too-late-vars)
  12778.                 ) ) ) )
  12779.                 (c-comment "~%")
  12780.                 (setq compilation-successful
  12781.                   (zerop *error-count*) ; Wert T, falls Compilation erfolgreich
  12782.             ) ) )
  12783.             (when new-output-stream
  12784.               (terpri *fasoutput-stream*) (close *fasoutput-stream*)
  12785.               (close *liboutput-stream*)
  12786.               (if *coutput-stream*
  12787.                 (close *coutput-stream*)
  12788.                 (when (probe-file *coutput-file*) (delete-file *coutput-file*))
  12789.               )
  12790.               (unless compilation-successful
  12791.                 (delete-file output-file) (delete-file liboutput-file)
  12792.                 (when (probe-file *coutput-file*) (delete-file *coutput-file*))
  12793.             ) )
  12794.         ) )
  12795.         (when new-listing-stream (close listing-stream))
  12796. ) ) ) )
  12797.  
  12798. ; Das mu▀ mit compile-file (s.o.) konsistent sein!
  12799. (defun compile-file-pathname (file &key (output-file 'T) listing warnings verbose print)
  12800.   (declare (ignore listing warnings verbose print))
  12801.   (setq file (or (first (search-file file *source-file-types*))
  12802.                  (merge-pathnames file (merge-pathnames '#".lsp"))
  12803.   )          )
  12804.   (when (and output-file (not (streamp output-file)))
  12805.     (setq output-file (if (eq output-file 'T)
  12806.                         (merge-pathnames '#".fas" file)
  12807.                         (merge-pathnames output-file)
  12808.     )                 )
  12809.   )
  12810.   output-file
  12811. )
  12812.  
  12813. (defun disassemble-closures (closure stream)
  12814.   (let ((closures '()))
  12815.     (labels ((mark (cl) ; trΣgt eine Closure cl (rekursiv) in closures ein.
  12816.                (push cl closures) ; cl markieren
  12817.                (dolist (c (closure-consts cl)) ; und alle Teil-Closures
  12818.                  (when #+CLISP (and (sys::closurep c) (compiled-function-p c))
  12819.                        #-CLISP (closure-p c)
  12820.                    (unless (member c closures) (mark c)) ; ebenfalls markieren
  12821.             )) ) )
  12822.       (mark closure) ; Haupt-Closure markieren
  12823.     )
  12824.     (dolist (c (nreverse closures)) ; alle Closures disassemblieren
  12825.       (disassemble-closure c stream)
  12826. ) ) )
  12827.  
  12828. #-CLISP
  12829. (defun disassemble-closure (closure &optional (stream *standard-output*))
  12830.   (format stream (DEUTSCH "~%~%Disassembly von Funktion ~S"
  12831.                   ENGLISH "~%~%Disassembly of function ~S"
  12832.                   FRANCAIS "~%~%DΘassemblage de la fonction ~S")
  12833.                  (closure-name closure)
  12834.   )
  12835.   (multiple-value-bind (req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p
  12836.                         byte-list const-list)
  12837.       (signature closure)
  12838.     (do ((L const-list (cdr L))
  12839.          (i 0 (1+ i)))
  12840.         ((null L))
  12841.       (format stream "~%(CONST ~S) = ~S" i (car L))
  12842.     )
  12843.     (format stream (DEUTSCH "~%~S notwendige Argumente"
  12844.                     ENGLISH "~%~S required arguments"
  12845.                     FRANCAIS "~%~S arguments nΘcessaires")
  12846.                    req-anz
  12847.     )
  12848.     (format stream (DEUTSCH "~%~S optionale Argumente"
  12849.                     ENGLISH "~%~S optional arguments"
  12850.                     FRANCAIS "~%~S arguments facultatifs")
  12851.                    opt-anz
  12852.     )
  12853.     (format stream (DEUTSCH "~%~:[Kein Rest-Parameter~;Rest-Parameter vorhanden~]"
  12854.                     ENGLISH "~%~:[No rest parameter~;Rest parameter~]"
  12855.                     FRANCAIS "~%~:[Pas de paramΦtre &REST~;ParamΦtre &REST~]")
  12856.                    rest-p
  12857.     )
  12858.     (if key-p
  12859.       (let ((kw-count (length keyword-list)))
  12860.         (format stream (DEUTSCH "~%~S Keyword-Parameter: ~{~S~^, ~}."
  12861.                         ENGLISH "~%~S keyword parameter~:P: ~{~S~^, ~}."
  12862.                         FRANCAIS "~%~S Mot~:P-clΘ : ~{~S~^, ~}.")
  12863.                        kw-count keyword-list
  12864.         )
  12865.         (when allow-other-keys-p
  12866.           (format stream (DEUTSCH "~%Andere Keywords sind zugelassen."
  12867.                           ENGLISH "~%Other keywords are allowed."
  12868.                           FRANCAIS "~%D'autres mots-clΘ sont permis.")
  12869.       ) ) )
  12870.       (format stream (DEUTSCH "~%Keine Keyword-Parameter"
  12871.                       ENGLISH "~%No keyword parameters"
  12872.                       FRANCAIS "~%Pas de mot-clΘ")
  12873.     ) )
  12874.     (let ((const-string-list (mapcar #'write-to-string const-list)))
  12875.       (do ((L (disassemble-LAP byte-list const-list) (cdr L)))
  12876.           ((null L))
  12877.         (let ((PC (caar L))
  12878.               (instr (cdar L)))
  12879.           (format stream "~%~S~6T~A" PC instr)
  12880.           (multiple-value-bind ... ; siehe unten
  12881.             ...
  12882.     ) ) ) )
  12883.     (format stream "~%")
  12884. ) )
  12885. #+CLISP
  12886. (defun disassemble-closure (closure &optional (stream *standard-output*))
  12887.   (terpri stream)
  12888.   (terpri stream)
  12889.   (write-string (DEUTSCH "Disassembly von Funktion "
  12890.                  ENGLISH "Disassembly of function "
  12891.                  FRANCAIS "DΘassemblage de la fonction ")
  12892.                 stream
  12893.   )
  12894.   (prin1 (closure-name closure) stream)
  12895.   (multiple-value-bind (req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p
  12896.                         byte-list const-list)
  12897.       (signature closure)
  12898.     (do ((L const-list (cdr L))
  12899.          (i 0 (1+ i)))
  12900.         ((null L))
  12901.       (terpri stream)
  12902.       (write-string "(CONST " stream)
  12903.       (prin1 i stream)
  12904.       (write-string ") = " stream)
  12905.       (prin1 (car L) stream)
  12906.     )
  12907.     (terpri stream)
  12908.     (prin1 req-anz stream)
  12909.     (write-string (DEUTSCH " notwendige Argumente"
  12910.                    ENGLISH " required arguments"
  12911.                    FRANCAIS " arguments nΘcessaires")
  12912.                   stream
  12913.     )
  12914.     (terpri stream)
  12915.     (prin1 opt-anz stream)
  12916.     (write-string (DEUTSCH " optionale Argumente"
  12917.                    ENGLISH " optional arguments"
  12918.                    FRANCAIS " arguments facultatifs")
  12919.                   stream
  12920.     )
  12921.     (terpri stream)
  12922.     (if rest-p
  12923.       (write-string (DEUTSCH "Rest-Parameter vorhanden"
  12924.                      ENGLISH "Rest parameter"
  12925.                      FRANCAIS "ParamΦtre &REST")
  12926.                     stream
  12927.       )
  12928.       (write-string (DEUTSCH "Kein Rest-Parameter"
  12929.                      ENGLISH "No rest parameter"
  12930.                      FRANCAIS "Pas de paramΦtre &REST")
  12931.                     stream
  12932.     ) )
  12933.     (if key-p
  12934.       (let ((kw-count (length keyword-list)))
  12935.         (terpri stream)
  12936.         (prin1 kw-count stream)
  12937.         (language-case
  12938.           (DEUTSCH (write-string " Keyword-Parameter: " stream))
  12939.           (ENGLISH (write-string " keyword parameter" stream)
  12940.                    (unless (eql kw-count 1) (write-string "s" stream))
  12941.                    (write-string ": " stream)
  12942.           )
  12943.           (FRANCAIS (write-string " mot" stream)
  12944.                     (unless (eql kw-count 1) (write-string "s" stream))
  12945.                     (write-string "-clΘ" stream)
  12946.         ) )
  12947.         (do ((L keyword-list))
  12948.             ((endp L))
  12949.           (prin1 (pop L) stream)
  12950.           (if (endp L) (write-string "." stream) (write-string ", " stream))
  12951.         )
  12952.         (when allow-other-keys-p
  12953.           (terpri stream)
  12954.           (write-string (DEUTSCH "Andere Keywords sind zugelassen."
  12955.                          ENGLISH "Other keywords are allowed."
  12956.                          FRANCAIS "D'autres mots-clΘ sont permis.")
  12957.                         stream
  12958.       ) ) )
  12959.       (progn
  12960.         (terpri stream)
  12961.         (write-string (DEUTSCH "Keine Keyword-Parameter"
  12962.                        ENGLISH "No keyword parameters"
  12963.                        FRANCAIS "Pas de mot-clΘ")
  12964.                       stream
  12965.     ) ) )
  12966.     (let ((const-string-list
  12967.             (mapcar #'(lambda (x) (sys::write-to-short-string x 35)) const-list)
  12968.          ))
  12969.       (do ((L (disassemble-LAP byte-list const-list) (cdr L)))
  12970.           ((null L))
  12971.         (let ((PC (caar L))
  12972.               (instr (cdar L)))
  12973.           (terpri stream)
  12974.           (prin1 PC stream)
  12975.           (dotimes (i (- 6 (sys::line-position stream))) (write-char #\Space stream)) ; Tab 6
  12976.           (princ instr stream) ; instr ausgeben, Symbole ohne Package-Marker!
  12977.           (multiple-value-bind (commentp comment)
  12978.             (when (consp instr)
  12979.               (case (first instr)
  12980.                 ((CALLS1 CALLS1&PUSH CALLS1&STORE CALLS1&JMPIFNOT CALLS1&JMPIF)
  12981.                   (values t (%funtabref (second instr)))
  12982.                 )
  12983.                 ((CALLS2 CALLS2&PUSH CALLS2&STORE CALLS2&JMPIFNOT CALLS2&JMPIF)
  12984.                   (values t (%funtabref (+ 256 (second instr))))
  12985.                 )
  12986.                 ((CALLSR CALLSR&PUSH CALLSR&STORE CALLSR&JMPIFNOT CALLSR&JMPIF)
  12987.                   (values t (%funtabref (+ funtabR-index (third instr))))
  12988.                 )
  12989.                 ((CALL CALL&PUSH)
  12990.                   (values 'string (nth (third instr) const-string-list))
  12991.                 )
  12992.                 ((CALL0 CALL1 CALL1&PUSH CALL1&JMPIFNOT CALL1&JMPIF
  12993.                   CALL2 CALL2&PUSH CALL2&JMPIFNOT CALL2&JMPIF
  12994.                   JMPIFEQTO JMPIFNOTEQTO CONST CONST&PUSH SETVALUE GETVALUE
  12995.                   GETVALUE&PUSH BIND CONST&STORE CONST&SYMBOL-FUNCTION&PUSH
  12996.                   CONST&SYMBOL-FUNCTION COPY-CLOSURE&PUSH COPY-CLOSURE
  12997.                   CONST&SYMBOL-FUNCTION&STORE TAGBODY-OPEN HANDLER-OPEN
  12998.                  )
  12999.                   (values 'string (nth (second instr) const-string-list))
  13000.             ) ) )
  13001.             (when commentp
  13002.               (dotimes (i (max 1 (- 42 (sys::line-position stream)))) (write-char #\Space stream)) ; Tab 42
  13003.               (write-string "; " stream)
  13004.               (if (eq commentp 'string)
  13005.                 (write-string comment stream)
  13006.                 (prin1 comment stream)
  13007.     ) ) ) ) ) )
  13008.     (terpri stream)
  13009. ) )
  13010.  
  13011. #-CROSS
  13012. (defun disassemble (object &aux name)
  13013.   (when (function-name-p object)
  13014.     (unless (fboundp object)
  13015.       (error-of-type 'undefined-function
  13016.         :name object
  13017.         (DEUTSCH "Funktion ~S ist undefiniert."
  13018.          ENGLISH "Undefined function ~S"
  13019.          FRANCAIS "Fonction non-dΘfinie ~S")
  13020.         object
  13021.     ) )
  13022.     (setq name object)
  13023.     (setq object (get-funname-symbol object))
  13024.     (setq object (or (get object 'sys::traced-definition)
  13025.                      (symbol-function object)
  13026.   ) )            )
  13027.   (when (and (consp object) (eq (car object) 'system::macro))
  13028.     (setq object (cdr object))
  13029.   )
  13030.   #+UNIX (when (stringp object)
  13031.            (return-from disassemble
  13032.              (disassemble-machine-code (sys::program-name) (sys::program-id)
  13033.                           object
  13034.          ) ) )
  13035.   #+UNIX (when (sys::code-address-of object)
  13036.            (return-from disassemble
  13037.              (disassemble-machine-code (sys::program-name) (sys::program-id)
  13038.                           (format nil "0x~X" (sys::code-address-of object))
  13039.          ) ) )
  13040.   (unless (sys::closurep object)
  13041.     (error-of-type 'error
  13042.       (DEUTSCH "~S kann nicht disassembliert werden."
  13043.        ENGLISH "Cannot disassemble ~S"
  13044.        FRANCAIS "Impossible de dΘassembler ~S")
  13045.       object
  13046.   ) )
  13047.   ; object ist eine Closure.
  13048.   (unless (compiled-function-p object)
  13049.     (setq object
  13050.       (compile-lambda (sys::%record-ref object 0) ; name
  13051.                       (sys::%record-ref object 1) ; lambdabody
  13052.                       (sys::%record-ref object 4) ; venv
  13053.                       (sys::%record-ref object 5) ; fenv
  13054.                       (sys::%record-ref object 6) ; benv
  13055.                       (sys::%record-ref object 7) ; genv
  13056.                       (sys::%record-ref object 8) ; denv
  13057.   ) ) )
  13058.   ; object ist eine compilierte Closure.
  13059.   (disassemble-closure object) ; Disassemblieren
  13060.   object ; compilierte Closure als Wert
  13061. )
  13062.